263 lines
10 KiB
Racket
263 lines
10 KiB
Racket
#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)
|