/sandboxes.rkt
http://github.com/elibarzilay/rudybot · Shell · 234 lines · 215 code · 15 blank · 4 comment · 3 complexity · d8f320a2aa45011d9d3fcb6391f19f4c MD5 · raw file
- #! /bin/sh
- #| Hey Emacs, this is -*-scheme-*- code!
- exec racket -l errortrace --require $0 --main -- ${1+"$@"}
- |#
- #lang racket
- (require scheme/sandbox
- net/url
- (planet schematics/schemeunit:3)
- (planet schematics/schemeunit:3/text-ui))
- (struct sandbox (evaluator last-used-time) #:transparent #:mutable)
- (provide (rename-out [public-make-sandbox make-sandbox]))
- (define (public-make-sandbox [lang '(begin (require scheme))])
- (sandbox
- (parameterize ([sandbox-output 'string]
- [sandbox-error-output 'string]
- [sandbox-eval-limits '(10 20)])
- (call-with-limits 10 #f
- (lambda ()
- (let ([port (and (string? lang)
- (regexp-match? #rx"^http://" lang)
- (get-pure-port (string->url lang)))])
- (if port
- (make-module-evaluator port)
- (make-evaluator lang))))))
- 0))
- (define (sandbox-eval sb string)
- (set-sandbox-last-used-time! sb (current-inexact-milliseconds))
- ((sandbox-evaluator sb) string))
- ;; returns the sandbox, force/new? can be #t to force a new sandbox,
- ;; or a box which will be set to #t if it was just created
- (define (get-sandbox-by-name ht name [lang '(begin (require scheme))] [force/new? #f])
- (define sb (hash-ref ht name #f))
- (define (make)
- (let ([sb (public-make-sandbox lang)])
- (when (box? force/new?) (set-box! force/new? #t))
- (add-grabber name sb)
- (hash-set! ht name sb)
- sb))
- (cond
- [(not (and sb (evaluator-alive? (sandbox-evaluator sb))))
- (when (and (not sb) (>= (hash-count ht) (*max-sandboxes*)))
- ;; evict the sandbox that has been unused the longest, don't do this
- ;; if we have a dead sandbox -- since we'll just replace it.
- (let ([moldiest #f])
- (for ([(name sb) (in-hash ht)])
- (let ([t (sandbox-last-used-time sb)])
- (unless (and moldiest (> t (car moldiest)))
- (set! moldiest (list t name sb)))))
- (when (not moldiest)
- (error "assertion-failure"))
- (kill-evaluator (sandbox-evaluator (caddr moldiest)))
- (hash-remove! ht (cadr moldiest))))
- ;; (when sb ...inform user about reset...)
- (make)]
- [(and force/new? (not (box? force/new?)))
- (kill-evaluator (sandbox-evaluator sb))
- (make)]
- [else sb]))
- (define (sandbox-get-stdout s)
- (get-output (sandbox-evaluator s)))
- (define (sandbox-get-stderr s)
- (get-error-output (sandbox-evaluator s)))
- (define *max-sandboxes* (make-parameter 3))
- ;; A subtle point here is memory that is accessible from the sandbox:
- ;; the value shouldn't be accessible outside the originating sandbox to
- ;; prevent this from being a security hole (use `give' to avoid being
- ;; charged for the allocated memory). Solve this by registering the
- ;; value with a gensym handle in the sending sandbox's namespace, and
- ;; make the handle accessible in the other sandbox. The handle is
- ;; available in the receiving sandbox and weakly held in the giving
- ;; sandbox, so if the receiver dies the handle can be GCed and with it
- ;; the value.
- (define given-handles (gensym 'given-values))
- (define (sandbox->given-registry sb)
- (call-in-sandbox-context (sandbox-evaluator sb)
- (lambda ()
- (namespace-variable-value given-handles #f
- (lambda ()
- (let ([t (make-weak-hasheq)])
- (namespace-set-variable-value! given-handles t)
- t))))
- #t))
- (define name->grabber (make-hash))
- ;; give : Sandbox String Any -> Void
- (define (sandbox-give from to val)
- ;; Evaluate the expression (all the usual things apply: should catch errors,
- ;; and require a single value too). See above for an explanation for the
- ;; handle.
- (define handle (gensym 'given))
- (hash-set! (sandbox->given-registry from) handle val)
- ;; Note: removing registered values depends on the handle being released, so
- ;; (a) the following should be done only for existing nicks (otherwise
- ;; error), (b) when a nick leaves it should be removed from this table
- (hash-set!
- name->grabber to
- (lambda ()
- (if (evaluator-alive? (sandbox-evaluator from))
- ;; note: this could be replaced with `val' -- but then this
- ;; closure will keep a reference for the value, making it
- ;; available from the receiving thread!
- (hash-ref (sandbox->given-registry from) handle
- (lambda ()
- (error 'grab "internal error (the value disappeared)")))
- (error 'grab "the sending evaluator died")))))
- ;; adds the GRAB binding to a given sandbox
- (define (add-grabber name sb)
- (call-in-sandbox-context (sandbox-evaluator sb)
- (lambda ()
- (define (GRAB) ((hash-ref name->grabber name (lambda () void))))
- (namespace-set-variable-value! 'GRAB GRAB))))
- (print-hash-table #t)
- (define sandboxes-tests
- (let ([*sandboxes-by-nick* (make-hash)])
- (test-suite
- "sandboxes"
- (test-case
- "simple get"
- (let ([s (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
- (check-pred sandbox? s)
- (check-equal? (sandbox-eval s "3") 3)))
- (test-case
- "command line args inaccessible"
- (let ([s (get-sandbox-by-name *sandboxes-by-nick* "charlie")])
- (check-pred zero? (vector-length (sandbox-eval s "(current-command-line-arguments)")))))
- (test-case
- "output"
- (let ([s (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
- (sandbox-eval s "(display \"You bet!\")")
- (check-equal? (sandbox-get-stdout s) "You bet!")
- (sandbox-eval s "(display \"Whatever\")")
- (check-equal? (sandbox-get-stdout s) "Whatever")))
- (test-suite
- "timeouts"
- (test-exn
- "sleeps too long"
- exn:fail?
- (lambda ()
- (sandbox-eval
- (get-sandbox-by-name *sandboxes-by-nick*"sleepy")
- "(sleep 10)")))
- (test-exn
- "gacks on incomplete input"
- exn:fail?
- (lambda ()
- (sandbox-eval
- (get-sandbox-by-name *sandboxes-by-nick*"oops")
- "("
- ))))
- (let ([charlies-sandbox #f]
- [keiths-sandbox #f])
- (test-suite
- "distinct "
- #:before
- (lambda ()
- (set! *sandboxes-by-nick* (make-hash))
- (set! charlies-sandbox (get-sandbox-by-name *sandboxes-by-nick* "charlie"))
- (set! keiths-sandbox (get-sandbox-by-name *sandboxes-by-nick* "keith")))
- (test-false
- "keeps sandboxes distinct, by name"
- (eq? charlies-sandbox keiths-sandbox))
- (test-case
- "remembers state"
- (sandbox-eval charlies-sandbox "(define x 99)")
- (let ([this-better-still-be-charlies (get-sandbox-by-name *sandboxes-by-nick*"charlie")])
- (check-equal? (sandbox-eval this-better-still-be-charlies
- "x")
- 99))
- (check-exn
- exn:fail?
- (lambda () (sandbox-eval keiths-sandbox "x"))
- "keith's sandbox didn't gack when I referenced 'x' -- even though we never defined it."))))
- ;; I'm not sure what I want to do here. On the one hand, I want
- ;; all calls to "getenv" to fail in the sandbox; on the other
- ;; hand, I cannot think of an elegant way to have the sandbox
- ;; itself ensure that (currently I'm counting on the bot's "main"
- ;; function to clear the environment).
- ;;; (test-case
- ;;; "environment"
- ;;; (let ([s (get-sandbox-by-name *sandboxes-by-nick* "yow")])
- ;;; (check-false (sandbox-eval s "(getenv \"HOME\")"))))
- (test-case
- "immediately recycles dead sandbox"
- (check-exn exn:fail:sandbox-terminated?
- (lambda ()
- (sandbox-eval
- (get-sandbox-by-name *sandboxes-by-nick* "yow")
- "(kill-thread (current-thread))")))
- (check-equal?
- (sandbox-eval
- (get-sandbox-by-name *sandboxes-by-nick* "yow")
- "3")
- 3)
- )
- )))
- (provide get-sandbox-by-name
- sandbox-evaluator
- sandbox-eval
- sandbox-get-stderr
- sandbox-get-stdout
- sandbox-give
- sandboxes-tests
- main
- )
- (define (main . args)
- (printf "Main running ...~%")
- (exit (run-tests sandboxes-tests)))