/sandboxes.rkt

  1#! /bin/sh
  2#| Hey Emacs, this is -*-scheme-*- code!
  3exec  racket -l errortrace --require $0 --main -- ${1+"$@"}
  4|#
  5
  6#lang racket
  7
  8(require scheme/sandbox
  9         net/url
 10         (planet schematics/schemeunit:3)
 11         (planet schematics/schemeunit:3/text-ui))
 12
 13(struct sandbox (evaluator last-used-time) #:transparent #:mutable)
 14(provide (rename-out [public-make-sandbox make-sandbox]))
 15(define (public-make-sandbox [lang '(begin (require scheme))])
 16  (sandbox
 17   (parameterize ([sandbox-output       'string]
 18                  [sandbox-error-output 'string]
 19                  [sandbox-eval-limits '(10 20)])
 20     (call-with-limits 10 #f
 21       (lambda ()
 22         (let ([port (and (string? lang)
 23                          (regexp-match? #rx"^http://" lang)
 24                          (get-pure-port (string->url lang)))])
 25           (if port
 26             (make-module-evaluator port)
 27             (make-evaluator lang))))))
 28   0))
 29
 30(define (sandbox-eval sb string)
 31  (set-sandbox-last-used-time! sb (current-inexact-milliseconds))
 32  ((sandbox-evaluator sb) string))
 33
 34;; returns the sandbox, force/new? can be #t to force a new sandbox,
 35;; or a box which will be set to #t if it was just created
 36(define (get-sandbox-by-name ht name [lang '(begin (require scheme))] [force/new? #f])
 37  (define sb (hash-ref ht name #f))
 38  (define (make)
 39    (let ([sb (public-make-sandbox lang)])
 40      (when (box? force/new?) (set-box! force/new? #t))
 41      (add-grabber name sb)
 42      (hash-set! ht name sb)
 43      sb))
 44  (cond
 45    [(not (and sb (evaluator-alive? (sandbox-evaluator sb))))
 46     (when (and (not sb) (>= (hash-count ht) (*max-sandboxes*)))
 47       ;; evict the sandbox that has been unused the longest, don't do this
 48       ;; if we have a dead sandbox -- since we'll just replace it.
 49       (let ([moldiest #f])
 50         (for ([(name sb) (in-hash ht)])
 51           (let ([t (sandbox-last-used-time sb)])
 52             (unless (and moldiest (> t (car moldiest)))
 53               (set! moldiest (list t name sb)))))
 54         (when (not moldiest)
 55           (error "assertion-failure"))
 56         (kill-evaluator (sandbox-evaluator (caddr moldiest)))
 57         (hash-remove! ht (cadr moldiest))))
 58     ;; (when sb ...inform user about reset...)
 59     (make)]
 60    [(and force/new? (not (box? force/new?)))
 61     (kill-evaluator (sandbox-evaluator sb))
 62     (make)]
 63    [else sb]))
 64
 65(define (sandbox-get-stdout s)
 66  (get-output (sandbox-evaluator s)))
 67
 68(define (sandbox-get-stderr s)
 69  (get-error-output (sandbox-evaluator s)))
 70
 71(define *max-sandboxes* (make-parameter 3))
 72
 73;; A subtle point here is memory that is accessible from the sandbox:
 74;; the value shouldn't be accessible outside the originating sandbox to
 75;; prevent this from being a security hole (use `give' to avoid being
 76;; charged for the allocated memory).  Solve this by registering the
 77;; value with a gensym handle in the sending sandbox's namespace, and
 78;; make the handle accessible in the other sandbox.  The handle is
 79;; available in the receiving sandbox and weakly held in the giving
 80;; sandbox, so if the receiver dies the handle can be GCed and with it
 81;; the value.
 82(define given-handles (gensym 'given-values))
 83(define (sandbox->given-registry sb)
 84  (call-in-sandbox-context (sandbox-evaluator sb)
 85    (lambda ()
 86      (namespace-variable-value given-handles #f
 87        (lambda ()
 88          (let ([t (make-weak-hasheq)])
 89            (namespace-set-variable-value! given-handles t)
 90            t))))
 91    #t))
 92
 93(define name->grabber (make-hash))
 94
 95;; give : Sandbox String Any -> Void
 96(define (sandbox-give from to val)
 97  ;; Evaluate the expression (all the usual things apply: should catch errors,
 98  ;; and require a single value too).  See above for an explanation for the
 99  ;; handle.
100  (define handle (gensym 'given))
101  (hash-set! (sandbox->given-registry from) handle val)
102  ;; Note: removing registered values depends on the handle being released, so
103  ;; (a) the following should be done only for existing nicks (otherwise
104  ;; error), (b) when a nick leaves it should be removed from this table
105  (hash-set!
106   name->grabber to
107   (lambda ()
108     (if (evaluator-alive? (sandbox-evaluator from))
109       ;; note: this could be replaced with `val' -- but then this
110       ;; closure will keep a reference for the value, making it
111       ;; available from the receiving thread!
112       (hash-ref (sandbox->given-registry from) handle
113                 (lambda ()
114                   (error 'grab "internal error (the value disappeared)")))
115       (error 'grab "the sending evaluator died")))))
116
117;; adds the GRAB binding to a given sandbox
118(define (add-grabber name sb)
119  (call-in-sandbox-context (sandbox-evaluator sb)
120    (lambda ()
121      (define (GRAB) ((hash-ref name->grabber name (lambda () void))))
122      (namespace-set-variable-value! 'GRAB GRAB))))
123
124
125(print-hash-table #t)
126
127(define sandboxes-tests
128
129  (let ([*sandboxes-by-nick* (make-hash)])
130    (test-suite
131     "sandboxes"
132
133     (test-case
134      "simple get"
135      (let ([s (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
136        (check-pred sandbox? s)
137        (check-equal? (sandbox-eval s "3") 3)))
138
139     (test-case
140      "command line args inaccessible"
141      (let ([s (get-sandbox-by-name *sandboxes-by-nick* "charlie")])
142        (check-pred zero? (vector-length (sandbox-eval s "(current-command-line-arguments)")))))
143
144     (test-case
145      "output"
146      (let ([s (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
147        (sandbox-eval s "(display \"You bet!\")")
148        (check-equal? (sandbox-get-stdout s) "You bet!")
149        (sandbox-eval s "(display \"Whatever\")")
150        (check-equal? (sandbox-get-stdout s) "Whatever")))
151
152     (test-suite
153      "timeouts"
154      (test-exn
155       "sleeps too long"
156       exn:fail?
157       (lambda ()
158         (sandbox-eval
159          (get-sandbox-by-name *sandboxes-by-nick*"sleepy")
160          "(sleep 10)")))
161
162      (test-exn
163       "gacks on incomplete input"
164       exn:fail?
165       (lambda ()
166         (sandbox-eval
167          (get-sandbox-by-name *sandboxes-by-nick*"oops")
168          "("
169          ))))
170
171     (let ([charlies-sandbox #f]
172           [keiths-sandbox   #f])
173
174       (test-suite
175        "distinct "
176        #:before
177        (lambda ()
178          (set! *sandboxes-by-nick* (make-hash))
179          (set! charlies-sandbox (get-sandbox-by-name *sandboxes-by-nick* "charlie"))
180          (set! keiths-sandbox   (get-sandbox-by-name *sandboxes-by-nick* "keith")))
181        (test-false
182         "keeps sandboxes distinct, by name"
183         (eq? charlies-sandbox keiths-sandbox))
184        (test-case
185         "remembers state"
186         (sandbox-eval charlies-sandbox "(define x 99)")
187         (let ([this-better-still-be-charlies (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
188           (check-equal? (sandbox-eval this-better-still-be-charlies
189                                       "x")
190                         99))
191         (check-exn
192          exn:fail?
193          (lambda () (sandbox-eval keiths-sandbox "x"))
194          "keith's sandbox didn't gack when I referenced 'x' -- even though we never defined it."))))
195     ;; I'm not sure what I want to do here.  On the one hand, I want
196     ;; all calls to "getenv" to fail in the sandbox; on the other
197     ;; hand, I cannot think of an elegant way to have the sandbox
198     ;; itself ensure that (currently I'm counting on the bot's "main"
199     ;; function to clear the environment).
200
201;;;      (test-case
202;;;       "environment"
203;;;       (let ([s (get-sandbox-by-name *sandboxes-by-nick* "yow")])
204;;;         (check-false (sandbox-eval s "(getenv \"HOME\")"))))
205
206     (test-case
207      "immediately recycles dead sandbox"
208      (check-exn exn:fail:sandbox-terminated?
209                 (lambda ()
210                   (sandbox-eval
211                    (get-sandbox-by-name *sandboxes-by-nick* "yow")
212                    "(kill-thread (current-thread))")))
213      (check-equal?
214       (sandbox-eval
215        (get-sandbox-by-name *sandboxes-by-nick* "yow")
216        "3")
217       3)
218      )
219     )))
220
221(provide get-sandbox-by-name
222         sandbox-evaluator
223         sandbox-eval
224         sandbox-get-stderr
225         sandbox-get-stdout
226         sandbox-give
227         sandboxes-tests
228         main
229         )
230
231(define (main . args)
232  (printf "Main running ...~%")
233
234  (exit (run-tests sandboxes-tests)))