Fix I/O and sharing of environments

This commit is contained in:
Tony Garnock-Jones 2011-10-27 18:13:49 -04:00
parent 11f7435b1c
commit 6f4efca1d2
1 changed files with 15 additions and 10 deletions

View File

@ -22,10 +22,12 @@
(printf "Got API ~v\n" api)
(semaphore-wait (make-semaphore 0)))))
(define *shells* (make-hash))
(define *environments* (make-hash))
(define *interaction* (make-room 'interaction))
(define *interaction-handle* (make-parameter #f))
(define *prompt* "RacketSSH> ")
(define (->string/safe bs)
@ -72,25 +74,28 @@
(read-syntax "<ssh-session>" (current-input-port)))))
(thunk)))
(define (get-user-evaluator username)
(when (not (hash-has-key? *shells* username))
(hash-set! *shells* username (make-evaluator 'racket/base)))
(hash-ref *shells* username))
(define (get-user-environment username)
(when (not (hash-has-key? *environments* username))
(hash-set! *environments* username (make-base-namespace)))
(hash-ref *environments* username))
(define (repl-shell username in out)
(fprintf out "Hello, ~a.\n" username)
(define handle (join-room *interaction* username))
(define env (get-user-environment 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 (make-empty-namespace)))
(parameterize ((current-eval (get-user-evaluator username)))
(current-namespace env)
(sandbox-namespace-specs (list (lambda () env))))
(parameterize ((current-eval (make-evaluator '(begin))))
(printf "Hello, ~a.\n" username)
(eval `(,*interaction-handle* ,handle))
(eval `(define say ,(lambda (utterance)
(printf " You: ~a\n" (->string/safe utterance))
(send handle say utterance)
(printf " You: ~a\n" (->string/safe utterance))
(send (*interaction-handle*) say utterance)
(void))))
(call-with-interaction-prompt-read handle read-eval-print-loop))
(fprintf out "\nGoodbye!\n")