#lang racket/base ;; (Temporary) example client and server (require racket/set) (require racket/match) (require racket/contract) (require (only-in racket/port peek-bytes-avail!-evt)) (require "cook-port.rkt") (require "sandboxes.rkt") (require "ssh-numbers.rkt") (require "ssh-transport.rkt") (require "ssh-session.rkt") (require "ssh-channel.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") (require "os2-support.rkt") (define (main) (ground-vm (transition 'no-state (spawn (timer-driver 'timer-driver)) ;; PAPER NOTE: remove #:debug-name for presentation economy (spawn tcp-driver #:debug-name 'tcp-driver) (spawn tcp-spy #:debug-name 'tcp-spy) (spawn listener #:debug-name 'ssh-tcp-listener)))) (define listener (transition 'no-state (role (tcp-listener 2322) #:topic t #:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t))))) ;;--------------------------------------------------------------------------- (define (check-remote-identification! peer-identification-string) (define required-peer-identification-regex #rx"^SSH-2\\.0-.*") ;; Each identification string is both a cleartext indicator that ;; we've reached some notion of the right place and also input to ;; the hash function used during D-H key exchange. (when (not (regexp-match required-peer-identification-regex peer-identification-string)) (error 'ssh-session "Invalid peer identification string ~v" peer-identification-string))) (define (spy marker) (role (or (topic-subscriber (wild) #:monitor? #t) (topic-publisher (wild) #:monitor? #t)) [message (write `(,marker ,message)) (newline) (flush-output) (void)])) (define-syntax-rule (wait-for topic-of-interest action ...) (role/fresh role-name topic-of-interest #:state state #:on-presence (sequence-actions (transition state) (delete-role role-name) action ...))) (define (session-vm new-connection-topic) (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic)) (define local-identification #"SSH-2.0-RacketSSH_0.0") (define (issue-identification-string) (at-meta-level (cout (bytes-append local-identification #"\r\n")))) (define (read-handshake-and-become-reader) (transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't! (at-meta-level (role in-topic #:name 'socket-reader #:state state [(tcp-channel _ _ (? eof-object?)) (transition state (quit))] [(tcp-channel _ _ (? bytes? remote-identification)) (check-remote-identification! remote-identification) (sequence-actions (transition state) ;; First, set the incoming mode to bytes. (at-meta-level (cin (tcp-mode 'bytes))) ;; Then initialise the reader, switching to packet-reading mode. (lambda (ignored-state) (ssh-reader new-connection-topic)) ;; Finally, spawn the remaining processes and issue the initial credit to the reader. (spawn (ssh-writer new-connection-topic) #:exit-signal? #t #:debug-name 'ssh-writer) ;; Wait for the reader and writer get started, then tell ;; the reader we are ready for a single packet and spawn ;; the session manager. (wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t) (wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t) (send-message (inbound-credit 1)) (spawn (ssh-session local-identification remote-identification repl-boot 'server) #:exit-signal? #t #:debug-name 'ssh-session))))])))) (define (exn->outbound-packet reason) (outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason) (string->bytes/utf-8 (exn-message reason)) #""))) (define (disconnect-message-required? reason) (and (exn:fail:contract:protocol? reason) (not (exn:fail:contract:protocol-originated-at-peer? reason)))) (define (active-exception-handler reason) ;; This is kind of gross: because the absence handler gets invoked ;; several times in a row because of multiple flows intersecting ;; this role, we have to be careful to make the transmission of ;; the disconnection packet idempotent. ;; TODO: this is likely no longer true now we're using exit-signals %%% (define interesting? (disconnect-message-required? reason)) (transition inert-exception-handler (when interesting? (send-message (exn->outbound-packet reason))) (yield #:state state ;; gross (transition state (at-meta-level (quit #:reason (and interesting? reason))))))) (define (inert-exception-handler reason) inert-exception-handler) (nested-vm #:debug-name (debug-name 'ssh-session-vm new-connection-topic) (transition 'no-state (spawn event-relay #:debug-name (debug-name 'session-event-relay)) (spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay) (spy 'SSH) (issue-identification-string) ;; Expect identification string, then update (!) our inbound ;; subscription handler to switch to packet mode. (at-meta-level (cin (tcp-mode 'lines))) (at-meta-level (cin (tcp-credit 1))) (spawn (read-handshake-and-become-reader) #:exit-signal? #t #:debug-name 'ssh-reader) (spawn (transition active-exception-handler (role (topic-subscriber (exit-signal (wild) (wild))) #:state current-handler #:reason reason #:on-absence (current-handler reason))))))) ;;--------------------------------------------------------------------------- (define (repl-boot user-name) (transition 'no-repl-state (spawn event-relay #:debug-name (debug-name 'repl-event-relay)) (spy 'APP) (at-meta-level (role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild))) #:state state #:topic t #:on-presence (match t [(topic _ (channel-message (channel-stream-name _ cname) _) _) (transition state (spawn (repl-instance user-name cname) #:debug-name cname))]))))) ;; (repl-instance InputPort OutputPort InputPort OutputPort) (struct repl-instance-state (c2s-in ;; used by thread to read input from relay c2s-out ;; used by relay to feed input from remote to the thread s2c-in ;; used by relay to feed output from thread to remote s2c-out ;; used by thread to write output to relay ) #:prefab) (define (repl-instance user-name cname) (define inbound-stream (channel-stream-name #t cname)) (define outbound-stream (channel-stream-name #f cname)) (define (ch-do action-ctor stream body) (at-meta-level (action-ctor (channel-message stream body)))) (define (handle-channel-message state body) (match body [(channel-stream-request #"pty-req" _) (match-define (repl-instance-state old-in _ _ old-out) state) (define-values (cooked-in cooked-out) (cook-io old-in old-out "> ")) (transition (struct-copy repl-instance-state state [c2s-in cooked-in] [s2c-out cooked-out]) (ch-do send-feedback inbound-stream (channel-stream-ok)))] [(channel-stream-notify #"env" _) ;; Don't care (transition state)] [(channel-stream-request #"shell" _) (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state) (define buffer-size 1024) (define dummy-buffer (make-bytes buffer-size)) (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) (transition state (ch-do send-feedback inbound-stream (channel-stream-ok)) (role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild))) [_ (quit #:reason "REPL thread exited")]) (role (topic-subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))) ;; We're using peek-bytes-avail!-evt rather than ;; read-bytes-avail!-evt because of potential overwriting ;; of the buffer. The overwriting can happen when there's ;; any latency between handling the event and the next ;; firing of the event, since the peek-bytes-avail!-evt ;; will overwrite its buffer next time it's synced on. #:state state [(cons _ (? eof-object?)) (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) (close-input-port c2s-in) (close-output-port c2s-out) (close-input-port s2c-in) (close-output-port s2c-out) (transition state (quit))] [(cons _ (? number? count)) (transition state (ch-do send-message outbound-stream (channel-stream-data (read-bytes count s2c-in))))]))] [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT (channel-stream-eof)) (close-output-port (repl-instance-state-c2s-out state)) ;; ^ this signals the repl thread to exit. ;; Now, wait for it to do so. (transition state)] [(channel-stream-data bs) (write-bytes bs (repl-instance-state-c2s-out state)) (flush-output (repl-instance-state-c2s-out state)) (transition state (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))] [m (write `(channel inbound ,m)) (newline) (transition state)])) (match (channel-name-type cname) [#"session" (define-values (c2s-in c2s-out) (make-pipe)) (define-values (s2c-in s2c-out) (make-pipe)) (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) (at-meta-level (role (topic-subscriber (channel-message inbound-stream (wild))) #:state state #:on-presence (transition state (ch-do send-feedback inbound-stream (channel-stream-config (default-packet-limit) #"")) (ch-do send-feedback inbound-stream (channel-stream-credit 1024))) [(channel-message _ body) (handle-channel-message state body)])) (at-meta-level (role (topic-publisher (channel-message outbound-stream (wild))) [m (write `(channel outbound ,cname ,m)) (newline) (void)])))] [type (transition 'no-instance-state (at-meta-level (send-message (channel-message outbound-stream (channel-stream-open-failure SSH_OPEN_UNKNOWN_CHANNEL_TYPE (bytes-append #"Unknown channel type " type))))))])) ;;--------------------------------------------------------------------------- ;; TODO: module+ (main)