diff --git a/new-server.rkt b/new-server.rkt index 3f6ca12..c1e95aa 100644 --- a/new-server.rkt +++ b/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))) diff --git a/sandboxes.rkt b/sandboxes.rkt new file mode 100644 index 0000000..9400565 --- /dev/null +++ b/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)))