Extract identification string before switching to packet mode
This commit is contained in:
parent
e2e59bdf6c
commit
72acd94def
103
new-server.rkt
103
new-server.rkt
|
@ -13,47 +13,74 @@
|
||||||
(define server-addr (tcp-listener 2322))
|
(define server-addr (tcp-listener 2322))
|
||||||
|
|
||||||
(define (connection-handler local-addr remote-addr)
|
(define (connection-handler local-addr remote-addr)
|
||||||
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||||
(nested-vm
|
(nested-vm
|
||||||
(list 'ssh-session-vm remote-addr)
|
(list 'ssh-session-vm remote-addr)
|
||||||
(transition 'running
|
(lambda (nested-boot-pid)
|
||||||
(at-meta-level
|
(transition 'running
|
||||||
(send-message (tcp-channel local-addr remote-addr #"SSH-2.0-RacketSSH_0.0\r\n")))
|
|
||||||
(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
|
|
||||||
(role 'identification-handler (topic-subscriber %%%
|
|
||||||
|
|
||||||
(spawn (ssh-reader local-addr remote-addr) #:debug-name 'ssh-reader)
|
;; Issue identification string.
|
||||||
(spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
(at-meta-level
|
||||||
(yield #:state state
|
(send-message (tcp-channel local-addr
|
||||||
(transition state (send-message (inbound-credit 1))))
|
remote-addr
|
||||||
(role 'crash-listener
|
(bytes-append local-identification #"\r\n"))))
|
||||||
(set (topic-subscriber (wild) #:virtual? #t)
|
|
||||||
(topic-publisher (wild) #:virtual? #t))
|
;; Expect identification string, then update (!) our inbound
|
||||||
#:state state
|
;; subscription handler to switch to packet mode.
|
||||||
#:reason reason
|
|
||||||
#:on-absence
|
(at-meta-level (send-tcp-mode remote-addr local-addr 'lines))
|
||||||
;; This is kind of gross: because the absence handler gets
|
(at-meta-level (send-tcp-credit remote-addr local-addr 1))
|
||||||
;; invoked several times in a row because of multiple flows
|
|
||||||
;; intersecting this role, we have to be careful to make the
|
(spawn
|
||||||
;; transmission of the disconnection packet idempotent.
|
(transition 'handshake-is-stateless
|
||||||
(if (eq? state 'running)
|
(at-meta-level
|
||||||
(if (and (exn:fail:contract:protocol? reason)
|
(role 'socket-reader (topic-subscriber (tcp-channel remote-addr local-addr (wild)))
|
||||||
(not (exn:fail:contract:protocol-originated-at-peer? reason)))
|
#:state state
|
||||||
(transition 'error-packet-sent
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
(send-message (outbound-packet (ssh-msg-disconnect
|
(transition state (kill))]
|
||||||
(exn:fail:contract:protocol-reason-code reason)
|
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||||
(string->bytes/utf-8 (exn-message reason))
|
;; First, set the incoming mode to bytes. Then
|
||||||
#"")))
|
;; initialise the reader, switching to packet-reading
|
||||||
(yield #:state state
|
;; mode. Finally, spawn the remaining processes and
|
||||||
(transition state (at-meta-level (kill)))))
|
;; issue the initial credit to the reader.
|
||||||
(transition state (at-meta-level (kill #:reason reason))))
|
(extend-transition
|
||||||
state)
|
(prefix-transition (ssh-reader local-addr remote-addr)
|
||||||
[msg
|
(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes)))
|
||||||
(write (list 'SSH msg))
|
(spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
||||||
(newline)
|
;; Wait for a cycle to let the reader and writer get
|
||||||
(flush-output)
|
;; started, then tell the reader we are ready for a
|
||||||
state]))))
|
;; single packet.
|
||||||
|
(yield #:state state
|
||||||
|
(transition state (send-message (inbound-credit 1)))))])))
|
||||||
|
#:debug-name 'ssh-reader)
|
||||||
|
|
||||||
|
(role 'crash-listener
|
||||||
|
(set (topic-subscriber (wild) #:virtual? #t)
|
||||||
|
(topic-publisher (wild) #:virtual? #t))
|
||||||
|
#:state state
|
||||||
|
#: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.
|
||||||
|
(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)
|
||||||
|
[msg
|
||||||
|
(write (list 'SSH msg))
|
||||||
|
(newline)
|
||||||
|
(flush-output)
|
||||||
|
state])))))
|
||||||
|
|
||||||
(ground-vm
|
(ground-vm
|
||||||
(transition 'no-state
|
(transition 'no-state
|
||||||
|
|
|
@ -300,6 +300,8 @@
|
||||||
hmac-description)
|
hmac-description)
|
||||||
sequence-number
|
sequence-number
|
||||||
remaining-credit))
|
remaining-credit))
|
||||||
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
|
(transition state (kill))]
|
||||||
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
||||||
(define block-size (supported-cipher-block-size cipher-description))
|
(define block-size (supported-cipher-block-size cipher-description))
|
||||||
(define first-block-size block-size)
|
(define first-block-size block-size)
|
||||||
|
|
Loading…
Reference in New Issue