Make handlers etc *required* to return a transition structure.

This commit is contained in:
Tony Garnock-Jones 2012-07-23 17:21:47 -04:00
parent e94acab878
commit ff2cd74339
3 changed files with 137 additions and 137 deletions

View File

@ -47,17 +47,16 @@
(define (spy marker)
(role (or (topic-subscriber (wild) #:monitor? #t)
(topic-publisher (wild) #:monitor? #t))
#:state state
[message
(write `(,marker ,message))
(newline)
(flush-output)
state]))
(void)]))
(define-syntax-rule (wait-for topic-of-interest #:state state action ...)
(define-syntax-rule (wait-for topic-of-interest action ...)
(role/fresh role-name topic-of-interest
#:state state
#:on-presence (sequence-actions state
#:on-presence (sequence-actions (transition state)
(delete-role role-name)
action ...)))
@ -78,7 +77,7 @@
(transition state (kill))]
[(tcp-channel _ _ (? bytes? remote-identification))
(check-remote-identification! remote-identification)
(sequence-actions state
(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.
@ -91,9 +90,7 @@
;; 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)
#:state state
(wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t)
#:state state
(send-message (inbound-credit 1))
(spawn (ssh-session local-identification
remote-identification
@ -188,7 +185,7 @@
(ch-do send-feedback inbound-stream (channel-stream-ok)))]
[(channel-stream-notify #"env" _)
;; Don't care
state]
(transition state)]
[(channel-stream-request #"shell" _)
(match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state)
(define buffer-size 1024)
@ -197,10 +194,7 @@
(transition state
(ch-do send-feedback inbound-stream (channel-stream-ok))
(role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
#:state state
[_
(transition state
(kill #:reason "REPL thread exited"))])
[_ (kill #: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
@ -225,7 +219,7 @@
(close-output-port (repl-instance-state-c2s-out state))
;; ^ this signals the repl thread to exit.
;; Now, wait for it to do so.
state]
(transition state)]
[(channel-stream-data bs)
(write-bytes bs (repl-instance-state-c2s-out state))
(flush-output (repl-instance-state-c2s-out state))
@ -233,7 +227,7 @@
(ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))]
[m
(write `(channel inbound ,m)) (newline)
state]))
(transition state)]))
(match (channel-name-type cname)
[#"session"
(define-values (c2s-in c2s-out) (make-pipe))
@ -251,10 +245,9 @@
(handle-channel-message state body)]))
(at-meta-level
(role (topic-publisher (channel-message outbound-stream (wild)))
#:state state
[m
(write `(channel outbound ,cname ,m)) (newline)
state])))]
(void)])))]
[type
(transition 'no-instance-state
(at-meta-level (send-message

View File

@ -179,7 +179,7 @@
;; PacketHandler for handling SSH_MSG_IGNORE.
(define (handle-msg-ignore packet message conn)
conn)
(transition conn))
;; PacketHandler for handling SSH_MSG_UNIMPLEMENTED.
(define (handle-msg-unimplemented packet message conn)
@ -191,7 +191,7 @@
;; PacketHandler for handling SSH_MSG_DEBUG.
(define (handle-msg-debug packet message conn)
(log-debug (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))
conn)
(transition conn))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Key Exchange
@ -251,33 +251,35 @@
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
(define-values (private-key public-key) (generate-key group))
(define public-key-as-integer (bit-string->integer public-key #t #f))
(oneshot-handler conn
SSH_MSG_KEXDH_INIT
(lambda (packet message conn)
(define e (ssh-msg-kexdh-init-e message))
(define e-width (mpint-width e))
(define e-as-bytes (integer->bit-string e (* 8 e-width) #t))
(define shared-secret (compute-key private-key e-as-bytes))
(define hash-alg sha1)
(define-values (host-key-private host-key-public)
(host-key-algorithm->keys host-key-alg))
(define host-key-bytes
(pieces->ssh-host-key (public-key->pieces host-key-public)))
(define exchange-hash
(dh-exchange-hash hash-info
host-key-bytes
e
public-key-as-integer
(bit-string->integer shared-secret #t #f)))
(define h-signature (host-key-signature host-key-private
host-key-alg
exchange-hash))
(sequence-actions conn
(send-message (outbound-packet
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
public-key-as-integer
(bit-string->bytes h-signature))))
(lambda (conn) (finish shared-secret exchange-hash hash-alg conn)))))]
(transition
(oneshot-handler conn
SSH_MSG_KEXDH_INIT
(lambda (packet message conn)
(define e (ssh-msg-kexdh-init-e message))
(define e-width (mpint-width e))
(define e-as-bytes (integer->bit-string e (* 8 e-width) #t))
(define shared-secret (compute-key private-key e-as-bytes))
(define hash-alg sha1)
(define-values (host-key-private host-key-public)
(host-key-algorithm->keys host-key-alg))
(define host-key-bytes
(pieces->ssh-host-key (public-key->pieces host-key-public)))
(define exchange-hash
(dh-exchange-hash hash-info
host-key-bytes
e
public-key-as-integer
(bit-string->integer shared-secret #t #f)))
(define h-signature (host-key-signature host-key-private
host-key-alg
exchange-hash))
(sequence-actions (transition conn)
(send-message (outbound-packet
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
public-key-as-integer
(bit-string->bytes h-signature))))
(lambda (conn)
(finish shared-secret exchange-hash hash-alg conn))))))]
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
"Bad key-exchange algorithm ~v" kex-alg)]))
@ -293,31 +295,33 @@
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
(define-values (private-key public-key) (generate-key group))
(define public-key-as-integer (bit-string->integer public-key #t #f))
(sequence-actions conn
(sequence-actions (transition conn)
(send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
(lambda (conn)
(oneshot-handler conn
SSH_MSG_KEXDH_REPLY
(lambda (packet message conn)
(define f (ssh-msg-kexdh-reply-f message))
(define f-width (mpint-width f))
(define f-as-bytes (integer->bit-string f (* 8 f-width) #t))
(define shared-secret (compute-key private-key f-as-bytes))
(define hash-alg sha1)
(define host-key-bytes (ssh-msg-kexdh-reply-host-key message))
(define host-public-key
(pieces->public-key (ssh-host-key->pieces host-key-bytes)))
(define exchange-hash
(dh-exchange-hash hash-info
host-key-bytes
public-key-as-integer
f
(bit-string->integer shared-secret #t #f)))
(verify-host-key-signature! host-public-key
host-key-alg
exchange-hash
(ssh-msg-kexdh-reply-h-signature message))
(finish shared-secret exchange-hash hash-alg conn)))))]
(transition
(oneshot-handler conn
SSH_MSG_KEXDH_REPLY
(lambda (packet message conn)
(define f (ssh-msg-kexdh-reply-f message))
(define f-width (mpint-width f))
(define f-as-bytes (integer->bit-string f (* 8 f-width) #t))
(define shared-secret (compute-key private-key f-as-bytes))
(define hash-alg sha1)
(define host-key-bytes (ssh-msg-kexdh-reply-host-key message))
(define host-public-key
(pieces->public-key (ssh-host-key->pieces host-key-bytes)))
(define exchange-hash
(dh-exchange-hash hash-info
host-key-bytes
public-key-as-integer
f
(bit-string->integer shared-secret #t #f)))
(verify-host-key-signature! host-public-key
host-key-alg
exchange-hash
(ssh-msg-kexdh-reply-h-signature
message))
(finish shared-secret exchange-hash hash-alg conn))))))]
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
"Bad key-exchange algorithm ~v" kex-alg)]))
@ -409,41 +413,42 @@
(extend (bytes-append key (hash-alg (bit-string->bytes
(bit-string (k-h-prefix :: binary)
(key :: binary))))))))))
(oneshot-handler (struct-copy connection conn
[session-id session-id]) ;; just in case it changed
SSH_MSG_NEWKEYS
(lambda (newkeys-packet newkeys-message conn)
;; First, send our SSH_MSG_NEWKEYS,
;; incrementing the various counters, and then
;; apply the new algorithms. Also arm our rekey
;; timer.
(define new-rekey-state (rekey-in-seconds-or-bytes
(rekey-interval)
(rekey-volume)
(connection-total-transferred conn)))
(transition
(set-handlers (struct-copy connection conn [rekey-state new-rekey-state])
SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
(send-message (outbound-packet (ssh-msg-newkeys)))
(send-message
(new-keys (connection-is-server? conn)
derive-key
c2s-enc s2c-enc
c2s-mac s2c-mac
c2s-zip s2c-zip))
(send-message (set-timer 'rekey-timer
(* (rekey-wait-deadline new-rekey-state) 1000)
'absolute))))))
(transition
(oneshot-handler (struct-copy connection conn
[session-id session-id]) ;; just in case it changed
SSH_MSG_NEWKEYS
(lambda (newkeys-packet newkeys-message conn)
;; First, send our SSH_MSG_NEWKEYS,
;; incrementing the various counters, and then
;; apply the new algorithms. Also arm our rekey
;; timer.
(define new-rekey-state (rekey-in-seconds-or-bytes
(rekey-interval)
(rekey-volume)
(connection-total-transferred conn)))
(transition
(set-handlers
(struct-copy connection conn [rekey-state new-rekey-state])
SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
(send-message (outbound-packet (ssh-msg-newkeys)))
(send-message
(new-keys (connection-is-server? conn)
derive-key
c2s-enc s2c-enc
c2s-mac s2c-mac
c2s-zip s2c-zip))
(send-message (set-timer 'rekey-timer
(* (rekey-wait-deadline new-rekey-state) 1000)
'absolute)))))))
(let ((t (if should-discard-first-kex-packet
(struct-copy connection (continue-after-discard conn) [discard-next-packet? #t])
(continue-after-discard conn))))
(sequence-actions t
(lambda (conn)
(if (rekey-wait? (connection-rekey-state conn))
(transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
(send-message (outbound-packet local-algs)))
conn)))))
(sequence-actions (continue-after-discard conn)
(when should-discard-first-kex-packet
(lambda (conn) (transition (struct-copy connection conn [discard-next-packet? #t]))))
(lambda (conn)
(if (rekey-wait? (connection-rekey-state conn))
(transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
(send-message (outbound-packet local-algs)))
(transition conn)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Service request manager
@ -456,11 +461,12 @@
(if (connection-authentication-state conn)
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
"Repeated authentication is not permitted")
(sequence-actions conn
(sequence-actions (transition conn)
(send-message (outbound-packet (ssh-msg-service-accept service)))
(lambda (conn) (oneshot-handler conn
SSH_MSG_USERAUTH_REQUEST
handle-msg-userauth-request))))]
(lambda (conn) (transition
(oneshot-handler conn
SSH_MSG_USERAUTH_REQUEST
handle-msg-userauth-request)))))]
[else
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
"Service ~v not supported"
@ -477,7 +483,7 @@
[(and (positive? (bytes-length user-name))
(equal? service-name #"ssh-connection"))
;; TODO: Actually implement client authentication
(sequence-actions conn
(sequence-actions (transition conn)
(send-message (outbound-packet (ssh-msg-userauth-success)))
(lambda (conn)
(start-connection-service
@ -594,7 +600,7 @@
(list (delete-role (list cname 'outbound))
(delete-role (list cname 'inbound)))]
[else (list)])])))]
[else conn]))
[else (transition conn)]))
(define (channel-roles cname initial-message-producer)
(define inbound-stream-name (channel-stream-name #t cname))
@ -605,11 +611,9 @@
(role (topic-subscriber (channel-message outbound-stream-name (wild)))
#:name (list cname 'outbound)
#:state conn
#:on-presence
(transition conn
(initial-message-producer inbound-stream-name outbound-stream-name))
#:on-absence
(maybe-close-channel cname conn 'local)
#:on-presence (transition conn
(initial-message-producer inbound-stream-name outbound-stream-name))
#:on-absence (maybe-close-channel cname conn 'local)
[(channel-message _ body)
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
(define remote-ref (ssh-channel-remote-ref ch))
@ -672,19 +676,20 @@
(define arbitrary-locally-originated-traffic
(channel-message arbitrary-locally-originated-stream (wild)))
(sequence-actions
(set-handlers conn
;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation
SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust
SSH_MSG_CHANNEL_DATA handle-msg-channel-data
SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request
SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success
SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure)
(transition
(set-handlers conn
;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation
SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust
SSH_MSG_CHANNEL_DATA handle-msg-channel-data
SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request
SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success
SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure))
;; Start responding to channel interest coming from the
;; application. We are responding to channels appearing from the
;; remote peer by virtue of our installation of the handler for
@ -702,7 +707,7 @@
(transition (update-channel cname values conn)
(channel-roles cname (lambda (inbound-stream outbound-stream)
'())))
conn)]))))
(transition conn))]))))
(define (handle-msg-channel-open packet message conn)
(match-define (ssh-msg-channel-open channel-type*
@ -766,7 +771,7 @@
(define ch (get-channel conn local-ref))
(define description (bit-string->bytes description*))
(define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
(sequence-actions conn
(sequence-actions (transition conn)
(send-message (channel-message inbound-stream
(channel-stream-open-failure reason description)))
(lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote))))
@ -828,8 +833,9 @@
"Not authenticated"))))
(define ((bump-total amount) conn)
(struct-copy connection conn
[total-transferred (+ (connection-total-transferred conn) amount)]))
(transition
(struct-copy connection conn
[total-transferred (+ (connection-total-transferred conn) amount)])))
;; (K V A -> A) A Hash<K,V> -> A
(define (hash-fold fn seed hash)
@ -843,7 +849,7 @@
(let ((algs ((local-algorithm-list))))
(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
(send-message (outbound-packet algs))))
conn))
(transition conn)))
;; PacketDispatcher. Handles the core transport message types.
(define base-packet-dispatcher
@ -874,23 +880,23 @@
(role (topic-subscriber (timer-expired 'rekey-timer (wild)))
#:state conn
[(timer-expired 'rekey-timer now)
(sequence-actions conn
(sequence-actions (transition conn)
maybe-rekey)])
(role (topic-subscriber (outbound-byte-credit (wild)))
#:state conn
[(outbound-byte-credit amount)
(sequence-actions conn
(sequence-actions (transition conn)
(bump-total amount)
maybe-rekey)])
(role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
#:state conn
[(inbound-packet sequence-number payload message transfer-size)
(sequence-actions conn
(sequence-actions (transition conn)
(lambda (conn)
(if (connection-discard-next-packet? conn)
(struct-copy connection conn [discard-next-packet? #f])
(transition (struct-copy connection conn [discard-next-packet? #f]))
(dispatch-packet sequence-number payload message conn)))
(bump-total transfer-size)
(send-message (inbound-credit 1))

View File

@ -385,7 +385,7 @@
(wild) (wild)))
#:state state
[(? new-keys? nk)
(struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)])])
(transition (struct-copy ssh-reader-state state [config (apply-negotiated-options nk #f)]))])
(role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -438,4 +438,5 @@
(wild) (wild)))
#:state state
[(? new-keys? nk)
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)])])))
(transition
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))