Use sequence-actions.
This commit is contained in:
Tony Garnock-Jones
parent
f57b68603a
commit
f59bec0145
|
|
@ -147,20 +147,18 @@
|
|||
(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)))
|
||||
(sequence-actions state
|
||||
;; First, set the incoming mode to bytes.
|
||||
(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes))
|
||||
;; Then initialise the reader, switching to packet-reading mode.
|
||||
(lambda (ignored-state) (ssh-reader local-addr remote-addr))
|
||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||
(spawn (ssh-writer local-addr remote-addr)
|
||||
#:monitor? #t
|
||||
#: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.
|
||||
|
||||
;; (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.)
|
||||
;; TODO: try using presence instead of the yield.
|
||||
(yield #:state state
|
||||
(transition state
|
||||
|
|
|
|||
148
ssh-session.rkt
148
ssh-session.rkt
|
|
@ -119,22 +119,20 @@
|
|||
(hash-remove d packet-type-number)))
|
||||
(cddr key-value-pairs))))))
|
||||
|
||||
;; Transition [ Byte Maybe<PacketHandler> ]* -> ConnectionState
|
||||
;; ConnectionState [ Byte Maybe<PacketHandler> ]* -> ConnectionState
|
||||
;; Installs (or removes) PacketHandlers in the given connection state;
|
||||
;; see extend-packet-dispatcher.
|
||||
(define (set-handlers t . key-value-pairs)
|
||||
(extend-transition* t
|
||||
(lambda (conn)
|
||||
(struct-copy connection conn
|
||||
[dispatch-table (apply extend-packet-dispatcher
|
||||
(connection-dispatch-table conn)
|
||||
key-value-pairs)]))))
|
||||
(define (set-handlers conn . key-value-pairs)
|
||||
(struct-copy connection conn
|
||||
[dispatch-table (apply extend-packet-dispatcher
|
||||
(connection-dispatch-table conn)
|
||||
key-value-pairs)]))
|
||||
|
||||
;; Transition Byte PacketHandler -> ConnectionState
|
||||
;; Installs a PacketHandler that removes the installed dispatch entry
|
||||
;; and then delegates to its argument.
|
||||
(define (oneshot-handler t packet-type-number packet-handler)
|
||||
(set-handlers t
|
||||
(define (oneshot-handler conn packet-type-number packet-handler)
|
||||
(set-handlers conn
|
||||
packet-type-number
|
||||
(lambda (packet message conn)
|
||||
(packet-handler packet
|
||||
|
|
@ -273,11 +271,12 @@
|
|||
(define h-signature (host-key-signature host-key-private
|
||||
host-key-alg
|
||||
exchange-hash))
|
||||
(prefix-transition (finish shared-secret exchange-hash hash-alg conn)
|
||||
(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)))))))]
|
||||
(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,7 +292,9 @@
|
|||
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))
|
||||
(prefix-transition
|
||||
(sequence-actions 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)
|
||||
|
|
@ -315,8 +316,7 @@
|
|||
host-key-alg
|
||||
exchange-hash
|
||||
(ssh-msg-kexdh-reply-h-signature message))
|
||||
(finish shared-secret exchange-hash hash-alg conn)))
|
||||
(send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))))]
|
||||
(finish shared-secret exchange-hash hash-alg conn)))))]
|
||||
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||
"Bad key-exchange algorithm ~v" kex-alg)]))
|
||||
|
||||
|
|
@ -437,7 +437,7 @@
|
|||
(let ((t (if should-discard-first-kex-packet
|
||||
(struct-copy connection (continue-after-discard conn) [discard-next-packet? #t])
|
||||
(continue-after-discard conn))))
|
||||
(prefix-transition* t
|
||||
(sequence-actions t
|
||||
(lambda (conn)
|
||||
(if (rekey-wait? (connection-rekey-state conn))
|
||||
(transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
|
||||
|
|
@ -455,10 +455,11 @@
|
|||
(if (connection-authentication-state conn)
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Repeated authentication is not permitted")
|
||||
(prefix-transition (oneshot-handler conn
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
handle-msg-userauth-request)
|
||||
(send-message (outbound-packet (ssh-msg-service-accept service)))))]
|
||||
(sequence-actions conn
|
||||
(send-message (outbound-packet (ssh-msg-service-accept service)))
|
||||
(lambda (conn) (oneshot-handler conn
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
handle-msg-userauth-request))))]
|
||||
[else
|
||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||
"Service ~v not supported"
|
||||
|
|
@ -475,15 +476,16 @@
|
|||
[(and (positive? (bytes-length user-name))
|
||||
(equal? service-name #"ssh-connection"))
|
||||
;; TODO: Actually implement client authentication
|
||||
(prefix-transition
|
||||
(sequence-actions conn
|
||||
(send-message (outbound-packet (ssh-msg-userauth-success)))
|
||||
(lambda (conn)
|
||||
(start-connection-service
|
||||
(set-handlers (struct-copy connection conn
|
||||
[authentication-state (authenticated user-name service-name)])
|
||||
SSH_MSG_USERAUTH_REQUEST
|
||||
(lambda (packet message conn)
|
||||
;; RFC4252 section 5.1 page 6
|
||||
conn)))
|
||||
(send-message (outbound-packet (ssh-msg-userauth-success))))]
|
||||
conn)))))]
|
||||
[else
|
||||
(transition conn
|
||||
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
||||
|
|
@ -660,7 +662,7 @@
|
|||
(channel-stream-name (wild) (channel-name #t (wild) (wild))))
|
||||
(define arbitrary-locally-originated-traffic
|
||||
(channel-message arbitrary-locally-originated-stream (wild)))
|
||||
(extend-transition
|
||||
(sequence-actions
|
||||
(set-handlers conn
|
||||
;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
|
||||
SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
|
||||
|
|
@ -764,9 +766,10 @@
|
|||
(define ch (get-channel conn local-ref))
|
||||
(define description (bit-string->bytes description*))
|
||||
(define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
|
||||
(prefix-transition (maybe-close-channel (ssh-channel-name ch) conn 'remote)
|
||||
(sequence-actions conn
|
||||
(send-message (channel-message inbound-stream
|
||||
(channel-stream-open-failure reason description)))))
|
||||
(channel-stream-open-failure reason description)))
|
||||
(lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote))))
|
||||
|
||||
(define (handle-msg-channel-window-adjust packet message conn)
|
||||
(match-define (ssh-msg-channel-window-adjust local-ref count) message)
|
||||
|
|
@ -824,11 +827,9 @@
|
|||
(else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||
"Not authenticated"))))
|
||||
|
||||
(define (bump-total t amount)
|
||||
(extend-transition* t
|
||||
(lambda (conn)
|
||||
(struct-copy connection conn
|
||||
[total-transferred (+ (connection-total-transferred conn) amount)]))))
|
||||
(define ((bump-total amount) conn)
|
||||
(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)
|
||||
|
|
@ -836,15 +837,13 @@
|
|||
(seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
|
||||
((not pos) seed)))
|
||||
|
||||
(define (rekey-wrap t)
|
||||
(extend-transition* t
|
||||
(lambda (conn)
|
||||
(define rekey (connection-rekey-state conn))
|
||||
(if (time-to-rekey? rekey conn)
|
||||
(let ((algs ((local-algorithm-list))))
|
||||
(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
|
||||
(send-message (outbound-packet algs))))
|
||||
conn))))
|
||||
(define (maybe-rekey conn)
|
||||
(define rekey (connection-rekey-state conn))
|
||||
(if (time-to-rekey? rekey conn)
|
||||
(let ((algs ((local-algorithm-list))))
|
||||
(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
|
||||
(send-message (outbound-packet algs))))
|
||||
conn))
|
||||
|
||||
;; PacketDispatcher. Handles the core transport message types.
|
||||
(define base-packet-dispatcher
|
||||
|
|
@ -858,38 +857,45 @@
|
|||
peer-identification-string
|
||||
application-boot
|
||||
session-role)
|
||||
(lambda (self-pid)
|
||||
(transition (connection #f
|
||||
base-packet-dispatcher
|
||||
0
|
||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||
#f
|
||||
'()
|
||||
(case session-role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f)
|
||||
(boot-specification
|
||||
(lambda (self-pid)
|
||||
(transition (connection #f
|
||||
base-packet-dispatcher
|
||||
0
|
||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||
#f
|
||||
'()
|
||||
(case session-role ((client) #f) ((server) #t))
|
||||
local-identification-string
|
||||
peer-identification-string
|
||||
#f)
|
||||
|
||||
(spawn (nested-vm 'ssh-application-vm application-boot)
|
||||
#:monitor? #t
|
||||
#:debug-name 'ssh-application-vm)
|
||||
(spawn (nested-vm 'ssh-application-vm application-boot)
|
||||
#:monitor? #t
|
||||
#:debug-name 'ssh-application-vm)
|
||||
|
||||
(role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
||||
#:state conn
|
||||
[(timer-expired 'rekey-timer now)
|
||||
(rekey-wrap conn)])
|
||||
(role 'rekey-waiter (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)))
|
||||
#:state conn
|
||||
[(outbound-byte-credit amount)
|
||||
(rekey-wrap (bump-total conn amount))])
|
||||
(role 'credit-listener (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)))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(let* ((t (if (connection-discard-next-packet? conn)
|
||||
(struct-copy connection conn [discard-next-packet? #f])
|
||||
(dispatch-packet sequence-number payload message conn)))
|
||||
(t (bump-total t transfer-size))
|
||||
(t (extend-transition t (send-message (inbound-credit 1)))))
|
||||
(rekey-wrap t))]))))
|
||||
(role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
||||
#:state conn
|
||||
[(inbound-packet sequence-number payload message transfer-size)
|
||||
(sequence-actions conn
|
||||
(lambda (conn)
|
||||
(if (connection-discard-next-packet? conn)
|
||||
(struct-copy connection conn [discard-next-packet? #f])
|
||||
(dispatch-packet sequence-number payload message conn)))
|
||||
(bump-total transfer-size)
|
||||
(send-message (inbound-credit 1))
|
||||
maybe-rekey)])))
|
||||
connection?))
|
||||
|
|
|
|||
Loading…
Reference in New Issue