Make role names optional, and remove role/anon. Remove inessential
role names from apps. Make nested-vm a macro.
This commit is contained in:
Tony Garnock-Jones
parent
4bad2698bb
commit
e94acab878
|
|
@ -27,7 +27,7 @@
|
|||
|
||||
(define listener
|
||||
(transition 'no-state
|
||||
(role 'connection-waiter (tcp-listener 2322)
|
||||
(role (tcp-listener 2322)
|
||||
#:topic t
|
||||
#:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
|
||||
|
||||
|
|
@ -45,8 +45,8 @@
|
|||
peer-identification-string)))
|
||||
|
||||
(define (spy marker)
|
||||
(role 'spy (or (topic-subscriber (wild) #:monitor? #t)
|
||||
(topic-publisher (wild) #:monitor? #t))
|
||||
(role (or (topic-subscriber (wild) #:monitor? #t)
|
||||
(topic-publisher (wild) #:monitor? #t))
|
||||
#:state state
|
||||
[message
|
||||
(write `(,marker ,message))
|
||||
|
|
@ -71,7 +71,8 @@
|
|||
(define (read-handshake-and-become-reader)
|
||||
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
||||
(at-meta-level
|
||||
(role 'socket-reader in-topic
|
||||
(role in-topic
|
||||
#:name 'socket-reader
|
||||
#:state state
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(transition state (kill))]
|
||||
|
|
@ -125,43 +126,37 @@
|
|||
(define (inert-exception-handler reason)
|
||||
inert-exception-handler)
|
||||
|
||||
(nested-vm
|
||||
(debug-name 'ssh-session-vm new-connection-topic)
|
||||
;; 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)
|
||||
(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)
|
||||
(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)
|
||||
(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)))
|
||||
;; 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 (read-handshake-and-become-reader)
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-reader)
|
||||
|
||||
(spawn (transition active-exception-handler
|
||||
(role 'exit-signal-listener (topic-subscriber (exit-signal (wild) (wild)))
|
||||
#:state current-handler
|
||||
#:reason reason
|
||||
#:on-absence (current-handler reason))))))))
|
||||
(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) self-pid)
|
||||
(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 'channel-listener (topic-subscriber (channel-message (channel-stream-name #t (wild))
|
||||
(wild)))
|
||||
(role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild)))
|
||||
#:state state
|
||||
#:topic t
|
||||
#:on-presence (match t
|
||||
|
|
@ -201,13 +196,12 @@
|
|||
(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 'thread-death-listener (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
|
||||
(role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
|
||||
#:state state
|
||||
[_
|
||||
(transition state
|
||||
(kill #:reason "REPL thread exited"))])
|
||||
(role 'relay-out (topic-subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in)
|
||||
(wild)))
|
||||
(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
|
||||
|
|
@ -246,7 +240,7 @@
|
|||
(define-values (s2c-in s2c-out) (make-pipe))
|
||||
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
||||
(at-meta-level
|
||||
(role 'input (topic-subscriber (channel-message inbound-stream (wild)))
|
||||
(role (topic-subscriber (channel-message inbound-stream (wild)))
|
||||
#:state state
|
||||
#:on-presence (transition state
|
||||
(ch-do send-feedback inbound-stream (channel-stream-config
|
||||
|
|
@ -256,7 +250,7 @@
|
|||
[(channel-message _ body)
|
||||
(handle-channel-message state body)]))
|
||||
(at-meta-level
|
||||
(role 'output (topic-publisher (channel-message outbound-stream (wild)))
|
||||
(role (topic-publisher (channel-message outbound-stream (wild)))
|
||||
#:state state
|
||||
[m
|
||||
(write `(channel outbound ,cname ,m)) (newline)
|
||||
|
|
|
|||
|
|
@ -489,7 +489,8 @@
|
|||
conn))))
|
||||
(lambda (conn)
|
||||
(transition conn
|
||||
(spawn (nested-vm 'ssh-application-vm ((connection-application-boot conn) user-name))
|
||||
(spawn (nested-vm #:debug-name 'ssh-application-vm
|
||||
((connection-application-boot conn) user-name))
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-application-vm))))]
|
||||
[else
|
||||
|
|
@ -601,7 +602,8 @@
|
|||
(define (! conn message)
|
||||
(transition conn (send-message (outbound-packet message))))
|
||||
(list
|
||||
(role (list cname 'outbound) (topic-subscriber (channel-message outbound-stream-name (wild)))
|
||||
(role (topic-subscriber (channel-message outbound-stream-name (wild)))
|
||||
#:name (list cname 'outbound)
|
||||
#:state conn
|
||||
#:on-presence
|
||||
(transition conn
|
||||
|
|
@ -626,7 +628,8 @@
|
|||
[(channel-stream-open-failure reason description)
|
||||
(! (discard-channel cname conn)
|
||||
(ssh-msg-channel-open-failure remote-ref reason description #""))])])
|
||||
(role (list cname 'inbound) (topic-publisher (channel-message inbound-stream-name (wild)))
|
||||
(role (topic-publisher (channel-message inbound-stream-name (wild)))
|
||||
#:name (list cname 'inbound)
|
||||
#:state conn
|
||||
[(channel-message _ body)
|
||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||
|
|
@ -686,9 +689,8 @@
|
|||
;; application. We are responding to channels appearing from the
|
||||
;; remote peer by virtue of our installation of the handler for
|
||||
;; SSH_MSG_CHANNEL_OPEN above.
|
||||
(role 'channel-connector
|
||||
(set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t)
|
||||
(topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t))
|
||||
(role (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t)
|
||||
(topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t))
|
||||
#:state conn
|
||||
#:topic t
|
||||
#:on-presence
|
||||
|
|
@ -869,20 +871,20 @@
|
|||
#f
|
||||
application-boot)
|
||||
|
||||
(role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
||||
(role (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(sequence-actions conn
|
||||
maybe-rekey)])
|
||||
|
||||
(role 'credit-listener (topic-subscriber (outbound-byte-credit (wild)))
|
||||
(role (topic-subscriber (outbound-byte-credit (wild)))
|
||||
#:state conn
|
||||
[(outbound-byte-credit amount)
|
||||
(sequence-actions conn
|
||||
(bump-total amount)
|
||||
maybe-rekey)])
|
||||
|
||||
(role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
||||
(role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(sequence-actions conn
|
||||
|
|
|
|||
|
|
@ -290,7 +290,8 @@
|
|||
|
||||
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
|
||||
(at-meta-level
|
||||
(role 'socket-reader in-topic
|
||||
(role in-topic
|
||||
#:name 'socket-reader
|
||||
#:state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
|
|
@ -369,7 +370,7 @@
|
|||
(actual-hmac ,received-hmac-bytes))
|
||||
SSH_DISCONNECT_MAC_ERROR
|
||||
"Corrupt MAC"))])]))
|
||||
(role 'credit-listener (topic-subscriber (inbound-credit (wild)))
|
||||
(role (topic-subscriber (inbound-credit (wild)))
|
||||
#:state state
|
||||
[(inbound-credit amount)
|
||||
(define new-state (struct-copy ssh-reader-state state
|
||||
|
|
@ -377,17 +378,15 @@
|
|||
(+ amount (ssh-reader-state-remaining-credit state))]))
|
||||
(transition new-state
|
||||
(issue-credit new-state))])
|
||||
(role 'key-change-listener
|
||||
(topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
(role (topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)])])
|
||||
(role 'packet-publisher (topic-publisher (inbound-packet (wild) (wild) (wild) (wild)))
|
||||
#:state state)))
|
||||
(role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Encrypted Packet Output
|
||||
|
|
@ -398,9 +397,8 @@
|
|||
(define (ssh-writer new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (tcp-accept new-connection-topic))
|
||||
(transition (ssh-writer-state initial-crypto-configuration 0)
|
||||
(role 'packet-listener
|
||||
(set (topic-subscriber (outbound-packet (wild)))
|
||||
(topic-publisher (outbound-byte-credit (wild))))
|
||||
(role (set (topic-subscriber (outbound-packet (wild)))
|
||||
(topic-publisher (outbound-byte-credit (wild))))
|
||||
#:state (and state
|
||||
(ssh-writer-state (crypto-configuration cipher
|
||||
cipher-description
|
||||
|
|
@ -433,12 +431,11 @@
|
|||
(when (positive? mac-byte-count)
|
||||
(at-meta-level (cout computed-hmac-bytes)))
|
||||
(send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))])
|
||||
(role 'key-change-listener
|
||||
(topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
(role (topic-subscriber (new-keys (wild)
|
||||
(wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)
|
||||
(wild) (wild)))
|
||||
#:state state
|
||||
[(? new-keys? nk)
|
||||
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)])])))
|
||||
|
|
|
|||
Loading…
Reference in New Issue