Sandbox code from old os1 server; eval server.

new-server.rkt

@@ -6,6 +6,7 @@
 (require racket/contract)
 (require (only-in racket/port peek-bytes-avail!-evt))
 (require "cook-port.rkt")
+(require "sandboxes.rkt")
 
 (require "ssh-numbers.rkt")
 (require "ssh-transport.rkt")
@@ -71,24 +72,6 @@
 		       [(topic _ (channel-message (channel-stream-name _ cname) _) _)
 			(transition state (spawn (repl-instance cname) #:debug-name cname))])))))
 
-(define (repl-evaluator in out)
-  (fprintf out "Welcome!~n")
-  (flush-output out)
-  (let loop ()
-    (define v (read in))
-    (write `(REPL ,v)) (newline) (flush-output)
-    (cond
-     [(eof-object? v)
-      (fprintf out "Goodbye!~n")
-      (flush-output out)
-      (sleep 0.1)  ;; TODO: reliable transmission to avoid the sleep. (At least drain the pipe.)
-      ]
-     [else
-      (fprintf out "You said ~v~n" v)
-      (flush-output out)
-      (loop)]))
-  (close-input-port in)
-  (close-output-port out))
 
 ;; (repl-instance InputPort OutputPort InputPort OutputPort)
 (struct repl-instance-state (c2s-in ;; used by thread to read input from relay
@@ -106,7 +89,7 @@
     (match body
       [(channel-stream-request #"pty-req" _)
        (match-define (repl-instance-state old-in _ _ old-out) state)
-       (define-values (cooked-in cooked-out) (cook-io old-in old-out "RacketSSH> "))
+       (define-values (cooked-in cooked-out) (cook-io old-in old-out "> "))
        (transition (struct-copy repl-instance-state state
 				[c2s-in cooked-in]
 				[s2c-out cooked-out])
@@ -118,7 +101,9 @@
        (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
        (define buffer-size 1024)
        (define dummy-buffer (make-bytes buffer-size))
-       (define repl-thread (thread (lambda () (repl-evaluator c2s-in s2c-out))))
+       (define repl-thread (thread (lambda ()
+				     ;; TODO: thread username through
+				     (repl-shell "unknown" c2s-in s2c-out))))
        (transition state
 	 (ch-do send-feedback inbound-stream (channel-stream-ok))
 	 (role 'thread-death-listener (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))

sandboxes.rkt

@@ -0,0 +1,43 @@
+#lang racket/base
+;; Sandbox management and use.
+
+(require racket/match)
+(require racket/sandbox)
+
+(provide repl-shell)
+
+(struct user-state (name master-sandbox master-namespace) #:transparent)
+
+(define *user-states* (make-hash))
+
+(define (get-user-state username)
+  (when (not (hash-has-key? *user-states* username))
+    (let* ((sb (make-evaluator 'racket/base))
+	   (ns (call-in-sandbox-context sb current-namespace)))
+      (hash-set! *user-states* username
+		 (user-state username
+			     sb
+			     ns))))
+  (hash-ref *user-states* username))
+
+(define (repl-shell username in out)
+  (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)
+		 (sandbox-memory-limit 2) ;; megabytes
+		 (sandbox-eval-limits #f)
+		 (sandbox-namespace-specs (list (lambda () master-namespace))))
+    (printf "Hello, ~a.\n" username)
+    (define slave-sandbox (make-evaluator '(begin)))
+    ;; ^^ uses master-namespace via sandbox-namespace-specs
+    (parameterize ((current-namespace master-namespace)
+		   (current-eval slave-sandbox))
+      (read-eval-print-loop))
+    (fprintf out "\nGoodbye!\n")
+    (kill-evaluator slave-sandbox)
+    (close-input-port in)
+    (close-output-port out)))