syndicate-lang
/
racket-ssh-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Create per-user shells with persistent environments.

This commit is contained in:
Tony Garnock-Jones 2011-10-27 15:25:06 -04:00
parent ad7b120bf6
commit ae9a751ed3
1 changed files with 62 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
repl-server.rkt
View File

@ -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)