145 lines
4.8 KiB
Racket
145 lines
4.8 KiB
Racket
#lang racket/base
|
|
;; (Temporary) example client and server
|
|
|
|
(require racket/tcp)
|
|
(require racket/pretty)
|
|
(require racket/match)
|
|
(require racket/class)
|
|
(require racket/port)
|
|
(require racket/sandbox)
|
|
|
|
(require "ssh-service.rkt")
|
|
(require "standard-thread.rkt")
|
|
|
|
(require "conversation.rkt")
|
|
|
|
(struct user-state (name master-sandbox master-namespace) #:transparent)
|
|
|
|
(define *user-states* (make-hash))
|
|
|
|
(define *login-limit* (make-semaphore 3))
|
|
|
|
(define *interaction* (make-room 'interaction))
|
|
(spy-on *interaction*)
|
|
|
|
(define *interaction-handle* (make-parameter #f))
|
|
|
|
(define *prompt* "RacketSSH> ")
|
|
|
|
(define (->string/safe bs)
|
|
(cond
|
|
((string? bs) bs)
|
|
((bytes? bs) (with-handlers ((exn:fail? (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 (help)
|
|
(printf "This is RacketSSH, a secure REPL for Racket.\n")
|
|
(printf "Definitions made are kept in a per-user environment.\n")
|
|
(printf "Beyond core Racket,\n")
|
|
(printf " (say <any>) - communicates its argument to other logged-in users\n")
|
|
(printf " (help) - this help message\n")
|
|
(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/base))
|
|
(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))
|
|
(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)
|
|
(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)))
|
|
|
|
(define (limited-repl-shell username in out)
|
|
(call-with-semaphore *login-limit*
|
|
(lambda () (repl-shell username in out))
|
|
(lambda () (reject-login username in out))))
|
|
|
|
(define (reject-login username in out)
|
|
(parameterize ((current-input-port in)
|
|
(current-output-port out)
|
|
(current-error-port out))
|
|
(printf "Hello, ~a - unfortunately, the system is too busy to accept your\n" username)
|
|
(printf "login right now. Please try again later.\n")
|
|
(close-input-port in)
|
|
(close-output-port out)))
|
|
|
|
(define (t-server)
|
|
(define s (tcp-listen 2322 4 #t))
|
|
(printf "Accepting...\n")
|
|
(tcp-pty-ssh-server s limited-repl-shell #:prompt *prompt*))
|
|
|
|
(t-server)
|