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