Switch to fake-tcp
This commit is contained in:
parent
e4e69844b3
commit
7636862e31
|
@ -16,8 +16,6 @@
|
|||
(require "ssh-exceptions.rkt")
|
||||
(require "os2-support.rkt")
|
||||
|
||||
(define server-addr (tcp-listener 2322))
|
||||
|
||||
(define (main)
|
||||
(ground-vm
|
||||
(transition 'no-state
|
||||
|
@ -29,15 +27,9 @@
|
|||
|
||||
(define listener
|
||||
(transition 'no-state
|
||||
(role 'connection-waiter (topic-subscriber (tcp-channel (wild) server-addr (wild))
|
||||
#:monitor? #t)
|
||||
#:state state
|
||||
(role 'connection-waiter (tcp-listener 2322)
|
||||
#: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 (debug-name 'ssh-session-vm remote-addr)))]))))
|
||||
#:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
@ -184,26 +176,23 @@
|
|||
state]))
|
||||
|
||||
(define-syntax-rule (wait-for topic-of-interest #:state state action ...)
|
||||
(let ((role-name (gensym 'wait-for)))
|
||||
(role role-name topic-of-interest
|
||||
#:state state
|
||||
#:on-presence (sequence-actions state
|
||||
(delete-role role-name)
|
||||
action ...))))
|
||||
(role/fresh role-name topic-of-interest
|
||||
#:state state
|
||||
#:on-presence (sequence-actions state
|
||||
(delete-role role-name)
|
||||
action ...)))
|
||||
|
||||
(define (session-vm local-addr remote-addr)
|
||||
(define (session-vm new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (tcp-accept new-connection-topic))
|
||||
(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")))))
|
||||
(at-meta-level (cout (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)))
|
||||
(role 'socket-reader in-topic
|
||||
#:state state
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(transition state (kill))]
|
||||
|
@ -211,11 +200,11 @@
|
|||
(check-remote-identification! remote-identification)
|
||||
(sequence-actions state
|
||||
;; First, set the incoming mode to bytes.
|
||||
(at-meta-level (send-tcp-mode remote-addr local-addr 'bytes))
|
||||
(at-meta-level (cin (tcp-mode 'bytes)))
|
||||
;; Then initialise the reader, switching to packet-reading mode.
|
||||
(lambda (ignored-state) (ssh-reader local-addr remote-addr))
|
||||
(lambda (ignored-state) (ssh-reader new-connection-topic))
|
||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||
(spawn (ssh-writer local-addr remote-addr)
|
||||
(spawn (ssh-writer new-connection-topic)
|
||||
#:exit-signal? #t
|
||||
#:debug-name 'ssh-writer)
|
||||
;; Wait for the reader and writer get started, then tell
|
||||
|
@ -258,7 +247,7 @@
|
|||
inert-exception-handler)
|
||||
|
||||
(nested-vm
|
||||
(debug-name 'ssh-session-vm remote-addr)
|
||||
(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.
|
||||
|
@ -272,8 +261,8 @@
|
|||
|
||||
;; Expect identification string, then update (!) our inbound
|
||||
;; subscription handler to switch to packet mode.
|
||||
(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 (cin (tcp-mode 'lines)))
|
||||
(at-meta-level (cin (tcp-credit 1)))
|
||||
|
||||
(spawn (read-handshake-and-become-reader)
|
||||
#:exit-signal? #t
|
||||
|
|
|
@ -4,9 +4,9 @@
|
|||
(require "../racket-matrix/os2.rkt")
|
||||
(require "../racket-matrix/os2-event-relay.rkt")
|
||||
(require "../racket-matrix/os2-timer.rkt")
|
||||
(require "../racket-matrix/os2-tcp.rkt")
|
||||
(require "../racket-matrix/fake-tcp.rkt")
|
||||
|
||||
(provide (all-from-out "../racket-matrix/os2.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/os2-event-relay.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/os2-timer.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/os2-tcp.rkt"))
|
||||
(provide (all-from-out "../racket-matrix/fake-tcp.rkt"))
|
||||
|
|
|
@ -279,19 +279,18 @@
|
|||
|
||||
(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
|
||||
|
||||
(define (ssh-reader local-addr remote-addr)
|
||||
(define (ssh-reader new-connection-topic)
|
||||
(define-values (cin cout in-topic out-topic) (tcp-accept new-connection-topic))
|
||||
(define packet-size-limit (default-packet-limit))
|
||||
|
||||
(define (issue-credit state)
|
||||
(match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
|
||||
(when (positive? message-credit)
|
||||
(at-meta-level
|
||||
(send-tcp-credit remote-addr local-addr (supported-cipher-block-size desc)))))
|
||||
(at-meta-level (cin (tcp-credit (supported-cipher-block-size desc))))))
|
||||
|
||||
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
|
||||
(at-meta-level
|
||||
(role 'socket-reader
|
||||
(topic-subscriber (tcp-channel remote-addr local-addr (wild)))
|
||||
(role 'socket-reader in-topic
|
||||
#:state (and state
|
||||
(ssh-reader-state mode
|
||||
(crypto-configuration cipher
|
||||
|
@ -318,8 +317,7 @@
|
|||
,packet-length
|
||||
,payload-length
|
||||
,packet)])
|
||||
(at-meta-level
|
||||
(send-tcp-credit remote-addr local-addr mac-byte-count)))
|
||||
(at-meta-level (cin (tcp-credit mac-byte-count))))
|
||||
(finish-packet 0 packet-length payload-length packet)))
|
||||
|
||||
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
||||
|
@ -352,8 +350,7 @@
|
|||
[mode `(packet-body ,packet-length
|
||||
,payload-length
|
||||
,first-block)])
|
||||
(at-meta-level
|
||||
(send-tcp-credit remote-addr local-addr remaining-to-read)))
|
||||
(at-meta-level (cin (tcp-credit remaining-to-read))))
|
||||
(check-hmac packet-length payload-length first-block))]
|
||||
|
||||
[`(packet-body ,packet-length ,payload-length ,first-block)
|
||||
|
@ -398,7 +395,8 @@
|
|||
|
||||
(struct ssh-writer-state (config sequence-number) #:prefab)
|
||||
|
||||
(define (ssh-writer local-addr remote-addr)
|
||||
(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)))
|
||||
|
@ -431,11 +429,9 @@
|
|||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr encrypted-packet)))
|
||||
(at-meta-level (cout encrypted-packet))
|
||||
(when (positive? mac-byte-count)
|
||||
(at-meta-level
|
||||
(send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
|
||||
(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)
|
||||
|
|
Loading…
Reference in New Issue