From ae9a751ed340f6ee60f9246c5f95ebf33d6c0a1e Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Thu, 27 Oct 2011 15:25:06 -0400
Subject: [PATCH] Create per-user shells with persistent environments.

---
 repl-server.rkt | 65 ++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 62 insertions(+), 3 deletions(-)

diff --git a/repl-server.rkt b/repl-server.rkt
index 2d0792d..7caff6b 100644
--- a/repl-server.rkt
+++ b/repl-server.rkt
@@ -11,6 +11,8 @@
 (require "ssh-service.rkt")
 (require "standard-thread.rkt")
 
+(require "conversation.rkt")
+
 #;(define (t-client)
   (let-values (((i o) (tcp-connect "localhost"
 				   2323
@@ -20,8 +22,64 @@
       (printf "Got API ~v\n" api)
       (semaphore-wait (make-semaphore 0)))))
 
+(define *shells* (make-hash))
+
+(define *interaction* (make-room 'interaction))
+
+(define *prompt* "RacketSSH> ")
+
+(define (->string/safe bs)
+  (cond
+   ((string? bs) bs)
+   ((bytes? bs) (with-handlers ((exn? (lambda (e) (bytes->string/latin-1 bs))))
+		  (bytes->string/utf-8 bs)))
+   (else (call-with-output-string (lambda (p) (write bs p))))))
+
+(define (dump-interactions handle)
+  (display *prompt*)
+  (let retry-without-prompt ()
+    (sync (handle-evt (send handle listen-evt)
+		      (lambda (message)
+			(display "\033[1G\033[2K") ;; clear current line
+			(let loop ((message message))
+			  (when message
+			    (match message
+			      ((arrived who) (printf "*** ~a arrived\n" (->string/safe who)))
+			      ((departed who why) (printf "*** ~a departed (~a)\n"
+							  (->string/safe who)
+							  (->string/safe why)))
+			      ((says who what #f)
+			       (printf "    ~a: ~a\n" (->string/safe who) (->string/safe what)))
+			      ((says who what topic)
+			       (printf "    ~a (~a): ~a\n"
+				       (->string/safe who)
+				       (->string/safe topic)
+				       (->string/safe what))))
+			    (loop (send handle try-listen))))
+			(dump-interactions handle)))
+	  (handle-evt (peek-string-evt 1 0 #f (current-input-port))
+		      (lambda (s)
+			(cond
+			 ((eof-object? s))
+			 ((char-whitespace? (string-ref s 0))
+			  (read-string 1 (current-input-port))
+			  (retry-without-prompt))
+			 (else 'ready-to-read-something-real)))))))
+
+(define (call-with-interaction-prompt-read handle thunk)
+  (parameterize ((current-prompt-read (lambda ()
+					(dump-interactions handle)
+					(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 (repl-shell username in out)
   (fprintf out "Hello, ~a.\n" username)
+  (define handle (join-room *interaction* username))
   (parameterize ((current-input-port in)
 		 (current-output-port out)
 		 (current-error-port out)
@@ -29,8 +87,9 @@
 		 (sandbox-output out)
 		 (sandbox-error-output out)
 		 (current-namespace (make-empty-namespace)))
-    (parameterize ((current-eval (make-evaluator 'racket/base)))
-      (read-eval-print-loop))
+    (parameterize ((current-eval (get-user-evaluator username)))
+      (eval `(define say ,(lambda (utterance) (send handle say utterance) (void))))
+      (call-with-interaction-prompt-read handle read-eval-print-loop))
     (fprintf out "\nGoodbye!\n")
     (close-input-port in)
     (close-output-port out)))
@@ -38,7 +97,7 @@
 (define (t-server)
   (define s (tcp-listen 2322 4 #t "localhost"))
   (printf "Accepting...\n")
-  (tcp-pty-ssh-server s repl-shell))
+  (tcp-pty-ssh-server s repl-shell #:prompt *prompt*))
 
 (if (getenv "clientmode")
     (void) #;(t-client)