Gaucheのmoduleとdefine-in-moduleとevalで作るsandbox

まずはモジュールがどういうものか、いくつか確認してみます。

• Gauche ユーザリファレンス: 4.11 モジュール

モジュールは、シンボルを束縛へとマップするオブジェクト

モジュールは継承することもできます。 既存のモジュールを継承したモジュールに新しい束縛を足してexportすることにより、 既存のモジュールを拡張することができます。新しいモジュールの内部からは、 継承元のモジュールの束縛が(exportされていないものも含め)全て見えます。 (新しく作られるモジュールはデフォルトでgaucheモジュールを継承しています。 新しいモジュールからgaucheの組込み手続き等が使えるのはそのためです)。

モジュールは実行時データ構造です。実行時に任意の名前のモジュールを 手続き的に作成することができます。

• Gauche:evalと環境

define-moduleはモジュールに名前を付けるが、 Gaucheでは無名のモジュールを作ることもできる。

module

• Gauche ユーザリファレンス: 4.11 モジュール

select-moduleによって一度nullやschemeモジュールに 入ると、そこから他のモジュールに移ることはできなくなることに注意してください。 これらのモジュールからは、あらゆるモジュール操作構文が不可視だからです。

らしい。

ということで、nullモジュール内にすでにある束縛を見てみる。

(hash-table-keys (module-table (find-module 'null)))
;; -> (unquote-splicing quasiquote letrec-syntax syntax-rules set! lambda let* begin quote or unquote define case delay if let letrec and let-syntax cond do define-syntax)

確かにモジュール系の手続きや特殊形式が一式存在しない。ということはselect-moduleをnullモジュールに入れてあげれば、またuserモジュールなどに戻れるわけですね。

define-in-module

nullモジュールにselect-module特殊形式を入れてみる。

(define-in-module null select-module select-module)

(hash-table-keys (module-table (find-module 'null)))
;; -> (unquote-splicing quasiquote letrec-syntax syntax-rules set! lambda let* begin quote or unquote define case delay if select-module let letrec and let-syntax cond do define-syntax)

入ったようです。

select-moduleでnullモジュールに入ってみます。

(select-module null)

(module-name (current-module))
;; -> *** ERROR: unbound variable: current-module

(select-module user)

(module-name (current-module))
;; -> user

nullモジュール内にcurrent-moduleは無いのでエラーになってます。でもselect-moduleはあるのでuserモジュールに戻ってくることができました。

他にも追加してみる。

(define-in-module null current-module current-module)

(define-in-module null receive receive)
(define-in-module null values values)

(select-module null)

(current-module)
;; -> #<module null>

(receive (a b)
    (values 1 2)
  (quasiquote ((unquote a)(unquote b))))
;; -> (1 2)

eval

ところで、gaucheのevalの第二引数は（今のところ）モジュールらしいです。

• Gauche ユーザリファレンス: 6.19 eval と repl

Function: eval expr env
[R5RS] exprを評価します。envは下に述べる手続きにより 返される値でなければなりません。現時点では、それは単なる オブジェクトですが、Gaucheが将来、ファースト クラスの環境オブジェクトを採用する可能性はあります。

(eval '(print #`"Hello, ,(module-name (current-module)) module !!")
      (current-module))
;; Hello, user module !!
;; #<undef>

(eval '(print #`"Hello, ,(module-name (current-module)) module !!")
      (find-module 'gauche))
;; Hello, gauche module !!
;; #<undef>

sandbox

• サンドボックス (セキュリティ) - Wikipedia

サンドボックス（sandbox）とは、外部から受け取ったプログラムを保護された領域で動作させることによってシステムが不正に操作されるのを防ぐセキュリティモデルのこと。

nullモジュールを継承したモジュールを作れば、許可したい手続きだけを注入したsandboxが作れそうです。

(eval '(begin (define a 10)(define b 5)(print (+ a b)))
      (find-module 'null))
;; -> *** ERROR: unbound variable: +

+がないと怒られました。

+と、きっとprintもないのでnullモジュールに注入します。

(define-in-module null + +)
(define-in-module null print print)

(eval '(begin (define a 10)(define b 5)(print (+ a b)))
      (find-module 'null))
;; 15
;; #<undef>

sandboxを作ってみる。

(define-module sandbox)

(module-parents (find-module 'sandbox))
;; -> (#<module gauche.gf>)

まずdefine-moduleでsandboxモジュールを定義します。sandboxモジュールの親モジュールはgauche.gfモジュールになっているようです。ということは、userモジュールと同じだけの手続きやマクロが使えてしまいそうです。昨日書いてみたall-symbols手続きを少し改造して確認してみます。

• vallog: 初期状態で見えているsymbolたち（Gaucheのuserモジュール）

(define (all-parents module)
  (let ((parents (module-parents module)))
    (let rec ((parents parents)(acc '()))
      (if (null? parents)
          acc
          (rec (cdr parents)(append (cons (car parents) acc)
                                    (all-parents (car parents))))))))

(define (all-symbols module)
  (map (lambda (m)
         (sort (hash-table-keys (module-table m))
               (lambda (x y)
                 (string<? (symbol->string x)
                           (symbol->string y)))))
       (all-parents module)))

(length (apply append (all-symbols (find-module 'sandbox))))
;; -> 1423

1423個もありました。

これはsandboxとしてはまずそうです。sandboxモジュールはnullモジュールから直接継承してもらいたいので、継承関係をぶち壊すためにextendマクロを使います。

(eval '(extend null) (find-module 'sandbox))

(module-parents (find-module 'sandbox))
;; -> (#<module null>)

希望通りにsandboxモジュールはnullモジュールを直接継承したようです。

ホントに？

(module-parents (find-module 'sandbox))
;; -> (#<module null>)

(hash-table-keys (module-table (find-module 'sandbox)))
;; -> ()

(length (apply append (all-symbols (find-module 'sandbox))))
;; -> 22

(apply append (all-symbols (find-module 'sandbox)))
;; -> (and begin case cond define define-syntax delay do if lambda let let* let-syntax letrec letrec-syntax or quasiquote quote set! syntax-rules unquote unquote-splicing)

(module-parents (find-module 'sandbox))
;; -> (#<module null>)

よさそうです。

define-sandbox

こういう風に書きたいですよね。

(define-sandbox <name>)

これが下記のように展開されるマクロがあれば良さそうです。

(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(extend null) <name>))

書いてみます。

(define-macro (define-sandbox name)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval '(extend null) ,name)))

期待通りに展開されるか%macroexpandマクロで確認してみます。

(%macroexpand (define-sandbox hoge))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(extend null) hoge))

動作も期待通りでしょうか？

(define-sandbox hoge)

hoge
;; -> #<module hoge>

(module-parents hoge)
;; -> (#<module null>)

(apply append (all-symbols hoge))
;; -> (and begin case cond define define-syntax delay do if lambda let let* let-syntax letrec letrec-syntax or quasiquote quote set! syntax-rules unquote unquote-splicing)

良さそうです。

ですが・・・、sandbox内で使いたい手続きやマクロを全てdefine-in-moduleで定義していくのも結構しんどそうです。define-sandboxで下記のように書けたら嬉しいかもしれません。

(define-sandbox <name>
  (symbol ... ))

展開イメージはこんな感じ。

(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(extend null) <name>)
  (begin
    (define-in-module <name> symbol symbol)
    ... ))

define-sandboxマクロを編集します。

(define-macro (define-sandbox name . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

動作を確認してみます。

(%macroexpand (define-sandbox hoge))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(extend null) hoge) (begin))

(%macroexpand (define-sandbox fuga + * - /))
;; (begin
;;   (define-module fuga)
;;   (define fuga (find-module 'fuga))
;;   (eval '(extend null) fuga)
;;   (begin
;;     (define-in-module fuga + +)
;;     (define-in-module fuga * *)
;;     (define-in-module fuga - -)
;;     (define-in-module fuga / /)))

(define-sandbox fuga + * - /)

(hash-table-keys (module-table fuga))
;; -> (/ * - +)

(module-parents fuga)
;; -> (#<module null>)

良さそうですね。

でも、sandbox内で使いたい手続きやマクロを毎度一つずつ追加するのも面倒です。指定したモジュールだけsandbox内でuseできたら便利そうです。

(define-sandbox <name> (using-module ...)
  (symbol ...))

展開イメージはこうでしょうか。

(begin
  (define-module <name>)
  (define <name> (find-module (quote <name>)))
  (eval '(begin (use using-module) ...) <name>)
  (eval '(extend null) <name>)
  (begin
    (define-in-module <name> symbol symbol)
    ... ))

define-sandboxを拡張します。

(define-macro (define-sandbox name modules . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval (quote (begin ,@(map (lambda (m)
                                   `(use ,m))
                                 modules))) ,name)
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

%macroexpandしてみます。

(%macroexpand (define-sandbox hoge (srfi-1 util.list gauche.sequence)
                + - * /))
;; (begin
;;   (define-module hoge)
;;   (define hoge (find-module 'hoge))
;;   (eval '(begin (use srfi-1) (use util.list) (use gauche.sequence)) hoge)
;;   (eval '(extend null) hoge)
;;   (begin
;;     (define-in-module hoge + +)
;;     (define-in-module hoge - -)
;;     (define-in-module hoge * *)
;;     (define-in-module hoge / /)
;;     (undefined)))

期待通りの動きをするでしょうか。

(define-sandbox hoge (srfi-1 util.list gauche.sequence)
  + - * /)


(module-parents hoge)
;; -> (#<module null>)

(hash-table-keys (module-table hoge))
;; -> (/ * - +)

(eval 'iota hoge)
;; -> #<closure iota>

(eval 'assoc-ref hoge)
;; -> #<closure assoc-ref>

(eval 'fold-with-index hoge)
;; -> #<generic fold-with-index (3)>

(eval 'list hoge)
;; -> *** ERROR: unbound variable: list

(eval 'map hoge)
;; -> #<generic map (2)>

define-sandbox時に指定したモジュールからexportされている束縛はsandbox内から見えているようです。define-in-moduleで指定されていない束縛であるlistは見えていません。これで良さそうです。

取りあえずこれでdefine-sandboxは完成ということにします。

(define-macro (define-sandbox name modules . symbols)
  `(begin
     (define-module ,name)
     (define ,name (find-module (quote ,name)))
     (eval (quote (begin ,@(map (lambda (m)
                                   `(use ,m))
                                 modules))) ,name)
     (eval '(extend null) ,name)
     (begin
       ,@(map (lambda (sym)
                `(define-in-module ,name ,sym ,sym))
              symbols)
       (undefined))))

あとは、define-sandboxでsandboxを定義した後に束縛を追加したくなったりuseされるモジュールを追加したくなった場合のために、inject-sandbox-symbols, inject-sandbox-modulesのようなマクロがあると便利かもしれません。

これでネットワーク越しに受け取ったS式などを心置きなくevalできますね！

参考

@kikuchan98さんに教えてもらった内容を参考にしました。

追記

探してみたらkahuaにsandbox.scmというものがあった。どうやら上記のsandboxとは違ってブラックリストを指定するタイプみたい。それとmake-moduleを使って無名モジュールを作ってそれをsandboxにしているみたい。

• [KahuaProject] View of /Kahua/trunk/src/kahua/sandbox.scm

追記

• vallog: なんで Lisp/Scheme の変数名は長いの？
• vallog: Gauche: use してる module から export されてる symbol たち
• vallog: 初期状態で見えているsymbolたち（Gaucheのuserモジュール）