/sandboxes.rkt

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