diff --git a/repl-server.rkt b/repl-server.rkt index ea10c96..a13b46d 100644 --- a/repl-server.rkt +++ b/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 "" (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)