Fixup sandbox security by using master/slave sandbox setup (HT eli)

repl-server.rkt

@@ -13,16 +13,9 @@
 
 (require "conversation.rkt")
 
-#;(define (t-client)
-  (let-values (((i o) (tcp-connect "localhost"
-				   2323
-				   ;;22
-				   )))
-    (let ((api (ssh-session 'client i o)))
-      (printf "Got API ~v\n" api)
-      (semaphore-wait (make-semaphore 0)))))
+(struct user-state (name master-sandbox master-namespace) #:transparent)
 
-(define *environments* (make-hash))
+(define *user-states* (make-hash))
 
 (define *interaction* (make-room 'interaction))
 (spy-on *interaction*)
@@ -75,11 +68,6 @@
 					(read-syntax "<ssh-session>" (current-input-port)))))
     (thunk)))
 
-(define (get-user-environment username)
-  (when (not (hash-has-key? *environments* username))
-    (hash-set! *environments* username (make-base-namespace)))
-  (hash-ref *environments* username))
-
 (define (help)
   (printf "This is RacketSSH, a secure REPL for Racket.\n")
   (printf "Definitions made are kept in a per-user environment.\n")
@@ -89,28 +77,44 @@
   (printf "If the reader gets confused, try control-L to make it reprint the line\n")
   (printf "buffer, or ESC to clear the line buffer.\n"))
 
+(define (say utterance)
+  (printf "    You: ~a\n" (->string/safe utterance))
+  (send (*interaction-handle*) say utterance)
+  (void))
+
+(define (get-user-state username)
+  (when (not (hash-has-key? *user-states* username))
+    (let* ((sb (make-evaluator 'racket))
+	   (ns (call-in-sandbox-context sb current-namespace)))
+      (parameterize ((current-namespace ns))
+	(namespace-set-variable-value! 'help help)
+	(namespace-set-variable-value! 'say say))
+      (hash-set! *user-states* username
+		 (user-state username
+			     sb
+			     ns))))
+  (hash-ref *user-states* username))
+
 (define (repl-shell username in out)
   (define handle (join-room *interaction* username))
-  (define env (get-user-environment username))
+  (match-define (user-state _ master-sandbox master-namespace) (get-user-state username))
   (parameterize ((current-input-port in)
 		 (current-output-port out)
 		 (current-error-port out)
 		 (sandbox-input in)
 		 (sandbox-output out)
 		 (sandbox-error-output out)
-		 (current-namespace env)
-		 (sandbox-namespace-specs (list (lambda () env))))
-    (parameterize ((current-eval (make-evaluator '(begin))))
-      (printf "Hello, ~a.\n" username)
-      (printf "Type (help) for help.\n")
-      (eval `(,*interaction-handle* ,handle))
-      (eval `(define help ,help))
-      (eval `(define say ,(lambda (utterance)
-			    (printf "    You: ~a\n" (->string/safe utterance))
-			    (send (*interaction-handle*) say utterance)
-			    (void))))
+		 (sandbox-namespace-specs (list (lambda () master-namespace))))
+    (printf "Hello, ~a.\n" username)
+    (printf "Type (help) for help.\n")
+    (define slave-sandbox (make-evaluator '(begin)))
+    ;; ^^ uses master-namespace via sandbox-namespace-specs
+    (slave-sandbox `(,*interaction-handle* ,handle))
+    (parameterize ((current-namespace master-namespace)
+		   (current-eval slave-sandbox))
       (call-with-interaction-prompt-read handle read-eval-print-loop))
     (fprintf out "\nGoodbye!\n")
+    (kill-evaluator slave-sandbox)
     (close-input-port in)
     (close-output-port out)))
 
@@ -119,6 +123,4 @@
   (printf "Accepting...\n")
   (tcp-pty-ssh-server s repl-shell #:prompt *prompt*))
 
-(if (getenv "clientmode")
-    (void) #;(t-client)
-    (t-server))
+(t-server)