/sandboxes.rkt
Shell | 234 lines | 215 code | 15 blank | 4 comment | 3 complexity | d8f320a2aa45011d9d3fcb6391f19f4c MD5 | raw file
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)))