Improvements from codewalk with Sam and Matthias
This commit is contained in:
parent
1058f0e96f
commit
9501a73fc5
203
new-server.rkt
203
new-server.rkt
|
@ -14,6 +14,36 @@
|
||||||
|
|
||||||
(define server-addr (tcp-listener 2322))
|
(define server-addr (tcp-listener 2322))
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
(define listener
|
||||||
|
(transition 'no-state
|
||||||
|
(role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild))
|
||||||
|
#:virtual? #t)
|
||||||
|
#:state state
|
||||||
|
#:topic t
|
||||||
|
#:on-presence (match t
|
||||||
|
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #f)
|
||||||
|
(transition state
|
||||||
|
(spawn (session-vm server-addr remote-addr)
|
||||||
|
#:debug-name (list 'ssh-session-vm remote-addr)))]
|
||||||
|
;; PAPER NOTE: This second clause can be replaced with
|
||||||
|
;; [_ state] for presentation economy
|
||||||
|
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #t)
|
||||||
|
;; Ignore virtual flows. They just mean there's
|
||||||
|
;; someone willing to supply connections to us
|
||||||
|
;; at some point in the future.
|
||||||
|
state]))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
(define (check-remote-identification! peer-identification-string)
|
(define (check-remote-identification! peer-identification-string)
|
||||||
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
|
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
|
||||||
;; Each identification string is both a cleartext indicator that
|
;; Each identification string is both a cleartext indicator that
|
||||||
|
@ -88,105 +118,102 @@
|
||||||
SSH_OPEN_UNKNOWN_CHANNEL_TYPE
|
SSH_OPEN_UNKNOWN_CHANNEL_TYPE
|
||||||
(bytes-append #"Unknown channel type " type))))))]))
|
(bytes-append #"Unknown channel type " type))))))]))
|
||||||
|
|
||||||
(define (connection-handler local-addr remote-addr)
|
(define (spy marker)
|
||||||
|
(role 'spy (or (topic-subscriber (wild) #:virtual? #t)
|
||||||
|
(topic-publisher (wild) #:virtual? #t))
|
||||||
|
#:state state
|
||||||
|
[message
|
||||||
|
(write `(,marker ,message))
|
||||||
|
(newline)
|
||||||
|
(flush-output)
|
||||||
|
state]))
|
||||||
|
|
||||||
|
(define (session-vm local-addr remote-addr)
|
||||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||||
|
|
||||||
|
(define (issue-identification-string)
|
||||||
|
(at-meta-level
|
||||||
|
(send-message (tcp-channel local-addr
|
||||||
|
remote-addr
|
||||||
|
(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 'socket-reader (topic-subscriber (tcp-channel remote-addr local-addr (wild)))
|
||||||
|
#:state state
|
||||||
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
|
(transition state (kill))]
|
||||||
|
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||||
|
(check-remote-identification! remote-identification)
|
||||||
|
;; First, set the incoming mode to bytes. Then
|
||||||
|
;; initialise the reader, switching to packet-reading
|
||||||
|
;; mode. Finally, spawn the remaining processes and
|
||||||
|
;; issue the initial credit to the reader.
|
||||||
|
(extend-transition
|
||||||
|
(prefix-transition (ssh-reader local-addr remote-addr)
|
||||||
|
(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes)))
|
||||||
|
(spawn/monitor (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
||||||
|
;; Wait for a cycle to let the reader and writer get
|
||||||
|
;; started, then tell the reader we are ready for a
|
||||||
|
;; single packet and spawn the session manager.
|
||||||
|
(yield #:state state
|
||||||
|
(transition state
|
||||||
|
(send-message (inbound-credit 1))
|
||||||
|
(spawn/monitor (ssh-session local-identification
|
||||||
|
remote-identification
|
||||||
|
repl-boot
|
||||||
|
'server)
|
||||||
|
#: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 monitors %%%
|
||||||
|
(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 (kill #:reason (and interesting? reason)))))))
|
||||||
|
|
||||||
|
(define (inert-exception-handler reason)
|
||||||
|
inert-exception-handler)
|
||||||
|
|
||||||
(nested-vm
|
(nested-vm
|
||||||
(list 'ssh-session-vm remote-addr)
|
(list 'ssh-session-vm remote-addr)
|
||||||
|
;; TODO: use (not-yet-existing) macro variant of nested-vm to avoid
|
||||||
|
;; spuriously binding nested-boot-pid without blaming the wrong
|
||||||
|
;; process in case of error.
|
||||||
(lambda (nested-boot-pid)
|
(lambda (nested-boot-pid)
|
||||||
(transition 'running
|
(transition 'no-state
|
||||||
(spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
|
(spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
|
||||||
|
(spy 'SSH)
|
||||||
|
|
||||||
;; Issue identification string.
|
(issue-identification-string)
|
||||||
(at-meta-level
|
|
||||||
(send-message (tcp-channel local-addr
|
|
||||||
remote-addr
|
|
||||||
(bytes-append local-identification #"\r\n"))))
|
|
||||||
|
|
||||||
;; Expect identification string, then update (!) our inbound
|
;; Expect identification string, then update (!) our inbound
|
||||||
;; subscription handler to switch to packet mode.
|
;; subscription handler to switch to packet mode.
|
||||||
|
|
||||||
(at-meta-level (send-tcp-mode remote-addr local-addr 'lines))
|
(at-meta-level (send-tcp-mode remote-addr local-addr 'lines))
|
||||||
(at-meta-level (send-tcp-credit remote-addr local-addr 1))
|
(at-meta-level (send-tcp-credit remote-addr local-addr 1))
|
||||||
|
|
||||||
(spawn/monitor
|
(spawn/monitor (read-handshake-and-become-reader) #:debug-name 'ssh-reader)
|
||||||
(transition 'handshake-is-stateless
|
|
||||||
(at-meta-level
|
|
||||||
(role 'socket-reader (topic-subscriber (tcp-channel remote-addr local-addr (wild)))
|
|
||||||
#:state state
|
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
|
||||||
(transition state (kill))]
|
|
||||||
[(tcp-channel _ _ (? bytes? remote-identification))
|
|
||||||
(check-remote-identification! remote-identification)
|
|
||||||
;; First, set the incoming mode to bytes. Then
|
|
||||||
;; initialise the reader, switching to packet-reading
|
|
||||||
;; mode. Finally, spawn the remaining processes and
|
|
||||||
;; issue the initial credit to the reader.
|
|
||||||
(extend-transition
|
|
||||||
(prefix-transition (ssh-reader local-addr remote-addr)
|
|
||||||
(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes)))
|
|
||||||
(spawn/monitor (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
|
||||||
;; Wait for a cycle to let the reader and writer get
|
|
||||||
;; started, then tell the reader we are ready for a
|
|
||||||
;; single packet and spawn the session manager.
|
|
||||||
(yield #:state state
|
|
||||||
(transition state
|
|
||||||
(send-message (inbound-credit 1))
|
|
||||||
(spawn/monitor (ssh-session local-identification
|
|
||||||
remote-identification
|
|
||||||
repl-boot
|
|
||||||
'server)
|
|
||||||
#:debug-name 'ssh-session))))])))
|
|
||||||
#:debug-name 'ssh-reader)
|
|
||||||
|
|
||||||
(role 'spy (or (topic-subscriber (wild) #:virtual? #t)
|
(spawn (transition active-exception-handler
|
||||||
(topic-publisher (wild) #:virtual? #t))
|
(role 'monitor-listener (topic-subscriber (monitor (wild) (wild)))
|
||||||
#:state state
|
#:state current-handler
|
||||||
[message
|
#:reason reason
|
||||||
(write `(SSH ,message))
|
#:on-absence (current-handler reason))))))))
|
||||||
(newline)
|
|
||||||
(flush-output)
|
|
||||||
state])
|
|
||||||
|
|
||||||
(role 'monitor-listener (topic-subscriber (monitor (wild) (wild)))
|
;; TODO: module+
|
||||||
#:state state
|
(main)
|
||||||
#:reason reason
|
|
||||||
#:on-absence
|
|
||||||
;; 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 monitors %%%
|
|
||||||
(if (eq? state 'running)
|
|
||||||
(if (and (exn:fail:contract:protocol? reason)
|
|
||||||
(not (exn:fail:contract:protocol-originated-at-peer? reason)))
|
|
||||||
(transition 'error-packet-sent
|
|
||||||
(send-message (outbound-packet (ssh-msg-disconnect
|
|
||||||
(exn:fail:contract:protocol-reason-code reason)
|
|
||||||
(string->bytes/utf-8 (exn-message reason))
|
|
||||||
#"")))
|
|
||||||
(yield #:state state
|
|
||||||
(transition state (at-meta-level (kill)))))
|
|
||||||
(transition state (at-meta-level (kill #:reason reason))))
|
|
||||||
state))))))
|
|
||||||
|
|
||||||
(ground-vm
|
|
||||||
(transition 'no-state
|
|
||||||
(spawn (timer-driver 'timer-driver))
|
|
||||||
(spawn tcp-driver #:debug-name 'tcp-driver)
|
|
||||||
(spawn tcp-spy #:debug-name 'tcp-spy)
|
|
||||||
|
|
||||||
(spawn (transition 'no-state
|
|
||||||
(role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild))
|
|
||||||
#:virtual? #t)
|
|
||||||
#:state state
|
|
||||||
#:topic t
|
|
||||||
#:on-presence (match t
|
|
||||||
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #t)
|
|
||||||
;; Ignore virtual flows. They just mean there's
|
|
||||||
;; someone willing to supply connections to us
|
|
||||||
;; at some point in the future.
|
|
||||||
state]
|
|
||||||
[(topic 'publisher (tcp-channel remote-addr (== server-addr) _) #f)
|
|
||||||
(transition state
|
|
||||||
(spawn (connection-handler server-addr remote-addr)
|
|
||||||
#:debug-name (list 'ssh-session-vm remote-addr)))]))))))
|
|
||||||
|
|
Loading…
Reference in New Issue