Compare commits
3 Commits
main
...
marketplac
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | 253ce502a2 | |
Tony Garnock-Jones | 3c0603878f | |
Tony Garnock-Jones | 9033cd307c |
|
@ -0,0 +1 @@
|
||||||
|
compiled/
|
|
@ -0,0 +1,12 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Reexport racket-matrix module contents.
|
||||||
|
|
||||||
|
(require marketplace/sugar-untyped)
|
||||||
|
(require marketplace/drivers/tcp)
|
||||||
|
(require marketplace/drivers/timer-untyped)
|
||||||
|
(require marketplace/drivers/event-relay)
|
||||||
|
|
||||||
|
(provide (all-from-out marketplace/sugar-untyped))
|
||||||
|
(provide (all-from-out marketplace/drivers/tcp))
|
||||||
|
(provide (all-from-out marketplace/drivers/timer-untyped))
|
||||||
|
(provide (all-from-out marketplace/drivers/event-relay))
|
158
new-server.rkt
158
new-server.rkt
|
@ -14,22 +14,20 @@
|
||||||
(require "ssh-channel.rkt")
|
(require "ssh-channel.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
(require "os2-support.rkt")
|
(require "marketplace-support.rkt")
|
||||||
|
|
||||||
(define (main)
|
(define (main)
|
||||||
(ground-vm
|
(ground-vm (timer-driver)
|
||||||
(transition 'no-state
|
(tcp-driver)
|
||||||
(spawn (timer-driver 'timer-driver))
|
(tcp-spy)
|
||||||
;; PAPER NOTE: remove #:debug-name for presentation economy
|
(spawn #:debug-name 'ssh-tcp-listener #:child listener)))
|
||||||
(spawn tcp-driver #:debug-name 'tcp-driver)
|
|
||||||
(spawn tcp-spy #:debug-name 'tcp-spy)
|
|
||||||
(spawn listener #:debug-name 'ssh-tcp-listener))))
|
|
||||||
|
|
||||||
(define listener
|
(define listener
|
||||||
(transition 'no-state
|
(transition/no-state
|
||||||
(role (tcp-listener 2322)
|
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?)
|
||||||
#:topic t
|
#:observer
|
||||||
#:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
|
#:conversation r
|
||||||
|
#:on-presence (session-vm r))))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -45,59 +43,81 @@
|
||||||
peer-identification-string)))
|
peer-identification-string)))
|
||||||
|
|
||||||
(define (spy marker)
|
(define (spy marker)
|
||||||
(role (or (topic-subscriber (wild) #:monitor? #t)
|
(define (dump what message)
|
||||||
(topic-publisher (wild) #:monitor? #t))
|
(write `(,marker ,what ,message))
|
||||||
[message
|
|
||||||
(write `(,marker ,message))
|
|
||||||
(newline)
|
(newline)
|
||||||
(flush-output)
|
(flush-output)
|
||||||
(void)]))
|
(void))
|
||||||
|
(list
|
||||||
|
(endpoint #:subscriber (wild) #:everything
|
||||||
|
#:role r
|
||||||
|
#:on-presence (dump 'arrived r)
|
||||||
|
#:on-absence (dump 'departed r)
|
||||||
|
[message (dump 'message message)])
|
||||||
|
(endpoint #:publisher (wild) #:everything
|
||||||
|
#:role r
|
||||||
|
#:on-presence (dump 'arrived r)
|
||||||
|
#:on-absence (dump 'departed r)
|
||||||
|
[message (dump 'message message)])))
|
||||||
|
|
||||||
(define-syntax-rule (wait-for topic-of-interest action ...)
|
(define-syntax-rule (wait-as my-orientation topic action ...)
|
||||||
(role/fresh role-name topic-of-interest
|
(endpoint my-orientation topic #:observer
|
||||||
|
#:let-name endpoint-name
|
||||||
#:state state
|
#:state state
|
||||||
#:on-presence (sequence-actions (transition state)
|
#:on-presence (begin (printf "WAIT ENDED: ~v\n" topic)
|
||||||
(delete-role role-name)
|
(sequence-actions (transition state
|
||||||
action ...)))
|
(delete-endpoint endpoint-name)
|
||||||
|
action ...)))))
|
||||||
|
|
||||||
(define (session-vm new-connection-topic)
|
(define (session-vm new-conversation)
|
||||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||||
|
|
||||||
(define (issue-identification-string)
|
(define (issue-identification-string)
|
||||||
(at-meta-level (cout (bytes-append local-identification #"\r\n"))))
|
(at-meta-level
|
||||||
|
(send-message (tcp-channel local-addr remote-addr
|
||||||
|
(bytes-append local-identification #"\r\n")))))
|
||||||
|
|
||||||
(define (read-handshake-and-become-reader)
|
(define (read-handshake-and-become-reader)
|
||||||
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
(transition 'handshake-is-stateless ;; but, crucially, the ssh-reader proper isn't!
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(role in-topic
|
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||||
#:name 'socket-reader
|
#:name 'socket-reader
|
||||||
#:state state
|
#:state state
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
(transition state (quit))]
|
(transition state (quit))]
|
||||||
[(tcp-channel _ _ (? bytes? remote-identification))
|
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||||
|
(begin
|
||||||
(check-remote-identification! remote-identification)
|
(check-remote-identification! remote-identification)
|
||||||
(sequence-actions (transition state)
|
(sequence-actions (transition state)
|
||||||
;; First, set the incoming mode to bytes.
|
;; First, set the incoming mode to bytes.
|
||||||
(at-meta-level (cin (tcp-mode 'bytes)))
|
(at-meta-level
|
||||||
|
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
|
||||||
;; Then initialise the reader, switching to packet-reading mode.
|
;; Then initialise the reader, switching to packet-reading mode.
|
||||||
(lambda (ignored-state) (ssh-reader new-connection-topic))
|
(lambda (ignored-state) (ssh-reader new-conversation))
|
||||||
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
;; Finally, spawn the remaining processes and issue the initial credit to the reader.
|
||||||
(spawn (ssh-writer new-connection-topic)
|
(spawn #:debug-name 'ssh-writer
|
||||||
#:exit-signal? #t
|
#:child (ssh-writer new-conversation)
|
||||||
#:debug-name 'ssh-writer)
|
;; TODO: canary: #:exit-signal? #t
|
||||||
|
)
|
||||||
;; Wait for the reader and writer get started, then tell
|
;; Wait for the reader and writer get started, then tell
|
||||||
;; the reader we are ready for a single packet and spawn
|
;; the reader we are ready for a single packet and spawn
|
||||||
;; the session manager.
|
;; the session manager.
|
||||||
(wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t)
|
(printf "BOO\n")
|
||||||
(wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t)
|
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||||
|
(printf "YAY\n") (flush-output)
|
||||||
|
(wait-as #:publisher (outbound-packet (wild))
|
||||||
|
(printf "ALSO YAY\n") (flush-output)
|
||||||
(send-message (inbound-credit 1))
|
(send-message (inbound-credit 1))
|
||||||
(spawn (ssh-session local-identification
|
(spawn #:debug-name 'ssh-session
|
||||||
|
#:pid session-pid
|
||||||
|
#:child (ssh-session session-pid
|
||||||
|
local-identification
|
||||||
remote-identification
|
remote-identification
|
||||||
repl-boot
|
repl-boot
|
||||||
'server)
|
'server)
|
||||||
#:exit-signal? #t
|
;; TODO: canary: #:exit-signal? #t
|
||||||
#:debug-name 'ssh-session))))]))))
|
)))))]))))
|
||||||
|
|
||||||
(define (exn->outbound-packet reason)
|
(define (exn->outbound-packet reason)
|
||||||
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
(outbound-packet (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code reason)
|
||||||
|
@ -123,44 +143,43 @@
|
||||||
(define (inert-exception-handler reason)
|
(define (inert-exception-handler reason)
|
||||||
inert-exception-handler)
|
inert-exception-handler)
|
||||||
|
|
||||||
(nested-vm #:debug-name (debug-name 'ssh-session-vm new-connection-topic)
|
(nested-vm #:debug-name (list 'ssh-session-vm new-conversation)
|
||||||
(transition 'no-state
|
(event-relay 'ssh-event-relay)
|
||||||
(spawn event-relay #:debug-name (debug-name 'session-event-relay))
|
(timer-relay 'ssh-timer-relay)
|
||||||
(spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
|
|
||||||
(spy 'SSH)
|
(spy 'SSH)
|
||||||
|
|
||||||
(issue-identification-string)
|
(issue-identification-string)
|
||||||
|
|
||||||
;; Expect identification string, then update (!) our inbound
|
;; Expect identification string, then update (!) our inbound
|
||||||
;; subscription handler to switch to packet mode.
|
;; subscription handler to switch to packet mode.
|
||||||
(at-meta-level (cin (tcp-mode 'lines)))
|
(at-meta-level
|
||||||
(at-meta-level (cin (tcp-credit 1)))
|
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines)))
|
||||||
|
(send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
|
||||||
|
|
||||||
(spawn (read-handshake-and-become-reader)
|
(spawn #:debug-name 'ssh-reader
|
||||||
#:exit-signal? #t
|
#:child (read-handshake-and-become-reader)
|
||||||
#:debug-name 'ssh-reader)
|
;; TODO: canary: #:exit-signal? #t
|
||||||
|
)
|
||||||
|
|
||||||
(spawn (transition active-exception-handler
|
;; TODO: canary:
|
||||||
(role (topic-subscriber (exit-signal (wild) (wild)))
|
;; (spawn #:child
|
||||||
#:state current-handler
|
;; (transition active-exception-handler
|
||||||
#:reason reason
|
;; (role (topic-subscriber (exit-signal (wild) (wild)))
|
||||||
#:on-absence (current-handler reason)))))))
|
;; #:state current-handler
|
||||||
|
;; #:reason reason
|
||||||
|
;; #:on-absence (current-handler reason))))
|
||||||
|
))
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
(define (repl-boot user-name)
|
(define (repl-boot user-name)
|
||||||
(transition 'no-repl-state
|
(list
|
||||||
(spawn event-relay #:debug-name (debug-name 'repl-event-relay))
|
(event-relay 'app-event-relay)
|
||||||
(spy 'APP)
|
(spy 'APP)
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild)))
|
(endpoint #:subscriber (channel-message (channel-stream-name #t (wild)) (wild))
|
||||||
#:state state
|
#:conversation (channel-message (channel-stream-name _ cname) _)
|
||||||
#:topic t
|
#:on-presence (spawn #:debug-name cname #:child (repl-instance user-name cname))))))
|
||||||
#:on-presence (match t
|
|
||||||
[(topic _ (channel-message (channel-stream-name _ cname) _) _)
|
|
||||||
(transition state (spawn (repl-instance user-name cname)
|
|
||||||
#:debug-name cname))])))))
|
|
||||||
|
|
||||||
|
|
||||||
;; (repl-instance InputPort OutputPort InputPort OutputPort)
|
;; (repl-instance InputPort OutputPort InputPort OutputPort)
|
||||||
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
(struct repl-instance-state (c2s-in ;; used by thread to read input from relay
|
||||||
|
@ -193,9 +212,9 @@
|
||||||
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
(define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out))))
|
||||||
(transition state
|
(transition state
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-ok))
|
(ch-do send-feedback inbound-stream (channel-stream-ok))
|
||||||
(role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
|
(endpoint #:subscriber (cons (thread-dead-evt repl-thread) (wild))
|
||||||
[_ (quit #:reason "REPL thread exited")])
|
[_ (quit #:reason "REPL thread exited")])
|
||||||
(role (topic-subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)))
|
(endpoint #:subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild))
|
||||||
;; We're using peek-bytes-avail!-evt rather than
|
;; We're using peek-bytes-avail!-evt rather than
|
||||||
;; read-bytes-avail!-evt because of potential overwriting
|
;; read-bytes-avail!-evt because of potential overwriting
|
||||||
;; of the buffer. The overwriting can happen when there's
|
;; of the buffer. The overwriting can happen when there's
|
||||||
|
@ -204,22 +223,24 @@
|
||||||
;; will overwrite its buffer next time it's synced on.
|
;; will overwrite its buffer next time it's synced on.
|
||||||
#:state state
|
#:state state
|
||||||
[(cons _ (? eof-object?))
|
[(cons _ (? eof-object?))
|
||||||
|
(let ()
|
||||||
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
|
||||||
(close-input-port c2s-in)
|
(close-input-port c2s-in)
|
||||||
(close-output-port c2s-out)
|
(close-output-port c2s-out)
|
||||||
(close-input-port s2c-in)
|
(close-input-port s2c-in)
|
||||||
(close-output-port s2c-out)
|
(close-output-port s2c-out)
|
||||||
(transition state (quit))]
|
(transition state (quit)))]
|
||||||
[(cons _ (? number? count))
|
[(cons _ (? number? count))
|
||||||
(transition state
|
(transition state
|
||||||
(ch-do send-message outbound-stream (channel-stream-data
|
(ch-do send-message outbound-stream (channel-stream-data
|
||||||
(read-bytes count s2c-in))))]))]
|
(read-bytes count s2c-in))))]))]
|
||||||
[(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
[(or (channel-stream-data #"\4") ;; C-d a.k.a EOT
|
||||||
(channel-stream-eof))
|
(channel-stream-eof))
|
||||||
|
(let ()
|
||||||
(close-output-port (repl-instance-state-c2s-out state))
|
(close-output-port (repl-instance-state-c2s-out state))
|
||||||
;; ^ this signals the repl thread to exit.
|
;; ^ this signals the repl thread to exit.
|
||||||
;; Now, wait for it to do so.
|
;; Now, wait for it to do so.
|
||||||
(transition state)]
|
(transition state))]
|
||||||
[(channel-stream-data bs)
|
[(channel-stream-data bs)
|
||||||
(write-bytes bs (repl-instance-state-c2s-out state))
|
(write-bytes bs (repl-instance-state-c2s-out state))
|
||||||
(flush-output (repl-instance-state-c2s-out state))
|
(flush-output (repl-instance-state-c2s-out state))
|
||||||
|
@ -234,7 +255,7 @@
|
||||||
(define-values (s2c-in s2c-out) (make-pipe))
|
(define-values (s2c-in s2c-out) (make-pipe))
|
||||||
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
(transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out)
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(role (topic-subscriber (channel-message inbound-stream (wild)))
|
(endpoint #:subscriber (channel-message inbound-stream (wild))
|
||||||
#:state state
|
#:state state
|
||||||
#:on-presence (transition state
|
#:on-presence (transition state
|
||||||
(ch-do send-feedback inbound-stream (channel-stream-config
|
(ch-do send-feedback inbound-stream (channel-stream-config
|
||||||
|
@ -244,12 +265,13 @@
|
||||||
[(channel-message _ body)
|
[(channel-message _ body)
|
||||||
(handle-channel-message state body)]))
|
(handle-channel-message state body)]))
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(role (topic-publisher (channel-message outbound-stream (wild)))
|
(endpoint #:publisher (channel-message outbound-stream (wild))
|
||||||
[m
|
[m
|
||||||
|
(begin
|
||||||
(write `(channel outbound ,cname ,m)) (newline)
|
(write `(channel outbound ,cname ,m)) (newline)
|
||||||
(void)])))]
|
(void))])))]
|
||||||
[type
|
[type
|
||||||
(transition 'no-instance-state
|
(transition/no-state
|
||||||
(at-meta-level (send-message
|
(at-meta-level (send-message
|
||||||
(channel-message outbound-stream
|
(channel-message outbound-stream
|
||||||
(channel-stream-open-failure
|
(channel-stream-open-failure
|
||||||
|
|
|
@ -1,12 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Reexport racket-matrix module contents.
|
|
||||||
|
|
||||||
(require "../racket-matrix/os2.rkt")
|
|
||||||
(require "../racket-matrix/os2-event-relay.rkt")
|
|
||||||
(require "../racket-matrix/os2-timer.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/fake-tcp.rkt"))
|
|
|
@ -3,12 +3,6 @@
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
|
||||||
(require "ssh-numbers.rkt")
|
|
||||||
(require "ssh-message-types.rkt")
|
|
||||||
(require "ssh-exceptions.rkt")
|
|
||||||
|
|
||||||
(require "os2-support.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out ssh-channel)
|
(provide (struct-out ssh-channel)
|
||||||
|
|
||||||
(struct-out channel-name)
|
(struct-out channel-name)
|
||||||
|
|
|
@ -16,7 +16,7 @@
|
||||||
(require "ssh-transport.rkt")
|
(require "ssh-transport.rkt")
|
||||||
(require "ssh-channel.rkt")
|
(require "ssh-channel.rkt")
|
||||||
|
|
||||||
(require "os2-support.rkt")
|
(require "marketplace-support.rkt")
|
||||||
|
|
||||||
(provide rekey-interval
|
(provide rekey-interval
|
||||||
rekey-volume
|
rekey-volume
|
||||||
|
@ -495,10 +495,9 @@
|
||||||
conn))))
|
conn))))
|
||||||
(lambda (conn)
|
(lambda (conn)
|
||||||
(transition conn
|
(transition conn
|
||||||
(spawn (nested-vm #:debug-name 'ssh-application-vm
|
;; TODO: canary for NESTED VM!: #:exit-signal? #t
|
||||||
((connection-application-boot conn) user-name))
|
(nested-vm #:debug-name 'ssh-application-vm
|
||||||
#:exit-signal? #t
|
((connection-application-boot conn) user-name)))))]
|
||||||
#:debug-name 'ssh-application-vm))))]
|
|
||||||
[else
|
[else
|
||||||
(transition conn
|
(transition conn
|
||||||
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
||||||
|
@ -597,24 +596,25 @@
|
||||||
[(remote)
|
[(remote)
|
||||||
(case old-close-state
|
(case old-close-state
|
||||||
[(neither local)
|
[(neither local)
|
||||||
(list (delete-role (list cname 'outbound))
|
(list (delete-endpoint (list cname 'outbound))
|
||||||
(delete-role (list cname 'inbound)))]
|
(delete-endpoint (list cname 'inbound)))]
|
||||||
[else (list)])])))]
|
[else (list)])])))]
|
||||||
[else (transition conn)]))
|
[else (transition conn)]))
|
||||||
|
|
||||||
(define (channel-roles cname initial-message-producer)
|
(define (channel-endpoints cname initial-message-producer)
|
||||||
(define inbound-stream-name (channel-stream-name #t cname))
|
(define inbound-stream-name (channel-stream-name #t cname))
|
||||||
(define outbound-stream-name (channel-stream-name #f cname))
|
(define outbound-stream-name (channel-stream-name #f cname))
|
||||||
(define (! conn message)
|
(define (! conn message)
|
||||||
(transition conn (send-message (outbound-packet message))))
|
(transition conn (send-message (outbound-packet message))))
|
||||||
(list
|
(list
|
||||||
(role (topic-subscriber (channel-message outbound-stream-name (wild)))
|
(endpoint #:subscriber (channel-message outbound-stream-name (wild))
|
||||||
#:name (list cname 'outbound)
|
#:name (list cname 'outbound)
|
||||||
#:state conn
|
#:state conn
|
||||||
#:on-presence (transition conn
|
#:on-presence (transition conn
|
||||||
(initial-message-producer inbound-stream-name outbound-stream-name))
|
(initial-message-producer inbound-stream-name outbound-stream-name))
|
||||||
#:on-absence (maybe-close-channel cname conn 'local)
|
#:on-absence (maybe-close-channel cname conn 'local)
|
||||||
[(channel-message _ body)
|
[(channel-message _ body)
|
||||||
|
(let ()
|
||||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||||
(define remote-ref (ssh-channel-remote-ref ch))
|
(define remote-ref (ssh-channel-remote-ref ch))
|
||||||
(match body
|
(match body
|
||||||
|
@ -631,11 +631,12 @@
|
||||||
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
|
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
|
||||||
[(channel-stream-open-failure reason description)
|
[(channel-stream-open-failure reason description)
|
||||||
(! (discard-channel cname conn)
|
(! (discard-channel cname conn)
|
||||||
(ssh-msg-channel-open-failure remote-ref reason description #""))])])
|
(ssh-msg-channel-open-failure remote-ref reason description #""))]))])
|
||||||
(role (topic-publisher (channel-message inbound-stream-name (wild)))
|
(endpoint #:publisher (channel-message inbound-stream-name (wild))
|
||||||
#:name (list cname 'inbound)
|
#:name (list cname 'inbound)
|
||||||
#:state conn
|
#:state conn
|
||||||
[(channel-message _ body)
|
[(channel-message _ body)
|
||||||
|
(let ()
|
||||||
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
|
||||||
(define remote-ref (ssh-channel-remote-ref ch))
|
(define remote-ref (ssh-channel-remote-ref ch))
|
||||||
(match body
|
(match body
|
||||||
|
@ -658,7 +659,7 @@
|
||||||
[(channel-stream-ok)
|
[(channel-stream-ok)
|
||||||
(! conn (ssh-msg-channel-success remote-ref))]
|
(! conn (ssh-msg-channel-success remote-ref))]
|
||||||
[(channel-stream-fail)
|
[(channel-stream-fail)
|
||||||
(! conn (ssh-msg-channel-failure remote-ref))])])))
|
(! conn (ssh-msg-channel-failure remote-ref))]))])))
|
||||||
|
|
||||||
(define (channel-notify conn ch inbound? body)
|
(define (channel-notify conn ch inbound? body)
|
||||||
(transition conn
|
(transition conn
|
||||||
|
@ -670,11 +671,15 @@
|
||||||
;; Connection service
|
;; Connection service
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (respond-to-opened-outbound-channel conn cname)
|
||||||
|
(if (and (ground? cname)
|
||||||
|
(not (memf (ssh-channel-name=? cname) (connection-channels conn))))
|
||||||
|
(transition (update-channel cname values conn)
|
||||||
|
(channel-endpoints cname (lambda (inbound-stream outbound-stream)
|
||||||
|
'())))
|
||||||
|
(transition conn)))
|
||||||
|
|
||||||
(define (start-connection-service conn)
|
(define (start-connection-service conn)
|
||||||
(define arbitrary-locally-originated-stream
|
|
||||||
(channel-stream-name (wild) (channel-name #t (wild) (wild))))
|
|
||||||
(define arbitrary-locally-originated-traffic
|
|
||||||
(channel-message arbitrary-locally-originated-stream (wild)))
|
|
||||||
(sequence-actions
|
(sequence-actions
|
||||||
(transition
|
(transition
|
||||||
(set-handlers conn
|
(set-handlers conn
|
||||||
|
@ -694,20 +699,16 @@
|
||||||
;; application. We are responding to channels appearing from the
|
;; application. We are responding to channels appearing from the
|
||||||
;; remote peer by virtue of our installation of the handler for
|
;; remote peer by virtue of our installation of the handler for
|
||||||
;; SSH_MSG_CHANNEL_OPEN above.
|
;; SSH_MSG_CHANNEL_OPEN above.
|
||||||
(role (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t)
|
(endpoint #:publisher (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||||
(topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t))
|
#:observer
|
||||||
#:state conn
|
#:state conn
|
||||||
#:topic t
|
#:conversation (channel-message (channel-stream-name #t cname) _)
|
||||||
#:on-presence
|
#:on-presence (respond-to-opened-outbound-channel conn cname))
|
||||||
(match t
|
(endpoint #:subscriber (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
|
||||||
[(or (topic 'publisher (channel-message (channel-stream-name #f cname) _) #f)
|
#:observer
|
||||||
(topic 'subscriber (channel-message (channel-stream-name #t cname) _) #f))
|
#:state conn
|
||||||
(if (and (ground? cname)
|
#:conversation (channel-message (channel-stream-name #f cname) _)
|
||||||
(not (memf (ssh-channel-name=? cname) (connection-channels conn))))
|
#:on-presence (respond-to-opened-outbound-channel conn cname))))
|
||||||
(transition (update-channel cname values conn)
|
|
||||||
(channel-roles cname (lambda (inbound-stream outbound-stream)
|
|
||||||
'())))
|
|
||||||
(transition conn))]))))
|
|
||||||
|
|
||||||
(define (handle-msg-channel-open packet message conn)
|
(define (handle-msg-channel-open packet message conn)
|
||||||
(match-define (ssh-msg-channel-open channel-type*
|
(match-define (ssh-msg-channel-open channel-type*
|
||||||
|
@ -730,7 +731,7 @@
|
||||||
(transition (update-channel cname
|
(transition (update-channel cname
|
||||||
(lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
|
(lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
|
||||||
conn)
|
conn)
|
||||||
(channel-roles cname
|
(channel-endpoints cname
|
||||||
(lambda (inbound-stream outbound-stream)
|
(lambda (inbound-stream outbound-stream)
|
||||||
(list (send-feedback
|
(list (send-feedback
|
||||||
(channel-message outbound-stream
|
(channel-message outbound-stream
|
||||||
|
@ -859,12 +860,11 @@
|
||||||
SSH_MSG_DEBUG handle-msg-debug
|
SSH_MSG_DEBUG handle-msg-debug
|
||||||
SSH_MSG_KEXINIT handle-msg-kexinit))
|
SSH_MSG_KEXINIT handle-msg-kexinit))
|
||||||
|
|
||||||
(define (ssh-session local-identification-string
|
(define (ssh-session self-pid
|
||||||
|
local-identification-string
|
||||||
peer-identification-string
|
peer-identification-string
|
||||||
application-boot
|
application-boot
|
||||||
session-role)
|
session-role)
|
||||||
(boot-specification
|
|
||||||
(lambda (self-pid)
|
|
||||||
(transition (connection #f
|
(transition (connection #f
|
||||||
base-packet-dispatcher
|
base-packet-dispatcher
|
||||||
0
|
0
|
||||||
|
@ -877,28 +877,28 @@
|
||||||
#f
|
#f
|
||||||
application-boot)
|
application-boot)
|
||||||
|
|
||||||
(role (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
(endpoint #:subscriber (timer-expired 'rekey-timer (wild))
|
||||||
#:state conn
|
#:state conn
|
||||||
[(timer-expired 'rekey-timer now)
|
[(timer-expired 'rekey-timer now)
|
||||||
(sequence-actions (transition conn)
|
(sequence-actions (transition conn)
|
||||||
maybe-rekey)])
|
maybe-rekey)])
|
||||||
|
|
||||||
(role (topic-subscriber (outbound-byte-credit (wild)))
|
(endpoint #:subscriber (outbound-byte-credit (wild))
|
||||||
#:state conn
|
#:state conn
|
||||||
[(outbound-byte-credit amount)
|
[(outbound-byte-credit amount)
|
||||||
(sequence-actions (transition conn)
|
(sequence-actions (transition conn)
|
||||||
(bump-total amount)
|
(bump-total amount)
|
||||||
maybe-rekey)])
|
maybe-rekey)])
|
||||||
|
|
||||||
(role (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
(endpoint #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
|
||||||
#:state conn
|
#:state conn
|
||||||
[(inbound-packet sequence-number payload message transfer-size)
|
[(inbound-packet sequence-number payload message transfer-size)
|
||||||
(sequence-actions (transition conn)
|
(sequence-actions (transition conn)
|
||||||
(lambda (conn)
|
(lambda (conn)
|
||||||
(if (connection-discard-next-packet? conn)
|
(if (connection-discard-next-packet? conn)
|
||||||
(transition (struct-copy connection conn [discard-next-packet? #f]))
|
(transition
|
||||||
|
(struct-copy connection conn [discard-next-packet? #f]))
|
||||||
(dispatch-packet sequence-number payload message conn)))
|
(dispatch-packet sequence-number payload message conn)))
|
||||||
(bump-total transfer-size)
|
(bump-total transfer-size)
|
||||||
(send-message (inbound-credit 1))
|
(send-message (inbound-credit 1))
|
||||||
maybe-rekey)])))
|
maybe-rekey)])))
|
||||||
connection?))
|
|
||||||
|
|
|
@ -14,7 +14,7 @@
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
|
|
||||||
(require "os2-support.rkt")
|
(require "marketplace-support.rkt")
|
||||||
|
|
||||||
(provide (struct-out inbound-packet)
|
(provide (struct-out inbound-packet)
|
||||||
(struct-out inbound-credit)
|
(struct-out inbound-credit)
|
||||||
|
@ -279,18 +279,20 @@
|
||||||
|
|
||||||
(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
|
(struct ssh-reader-state (mode config sequence-number remaining-credit) #:prefab)
|
||||||
|
|
||||||
(define (ssh-reader new-connection-topic)
|
(define (ssh-reader new-conversation)
|
||||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||||
(define packet-size-limit (default-packet-limit))
|
(define packet-size-limit (default-packet-limit))
|
||||||
|
|
||||||
(define (issue-credit state)
|
(define (issue-credit state)
|
||||||
(match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
|
(match-define (ssh-reader-state _ (crypto-configuration _ desc _ _) _ message-credit) state)
|
||||||
(when (positive? message-credit)
|
(when (positive? message-credit)
|
||||||
(at-meta-level (cin (tcp-credit (supported-cipher-block-size desc))))))
|
(at-meta-level
|
||||||
|
(send-feedback (tcp-channel remote-addr local-addr
|
||||||
|
(tcp-credit (supported-cipher-block-size desc)))))))
|
||||||
|
|
||||||
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
|
(transition (ssh-reader-state 'packet-header initial-crypto-configuration 0 0)
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
(role in-topic
|
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?)
|
||||||
#:name 'socket-reader
|
#:name 'socket-reader
|
||||||
#:state (and state
|
#:state (and state
|
||||||
(ssh-reader-state mode
|
(ssh-reader-state mode
|
||||||
|
@ -303,6 +305,7 @@
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
(transition state (quit))]
|
(transition state (quit))]
|
||||||
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
[(tcp-channel _ _ (? bytes? encrypted-packet))
|
||||||
|
(let ()
|
||||||
(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)
|
||||||
(define subsequent-block-size (if cipher block-size 1))
|
(define subsequent-block-size (if cipher block-size 1))
|
||||||
|
@ -318,7 +321,9 @@
|
||||||
,packet-length
|
,packet-length
|
||||||
,payload-length
|
,payload-length
|
||||||
,packet)])
|
,packet)])
|
||||||
(at-meta-level (cin (tcp-credit mac-byte-count))))
|
(at-meta-level
|
||||||
|
(send-feedback (tcp-channel remote-addr local-addr
|
||||||
|
(tcp-credit mac-byte-count)))))
|
||||||
(finish-packet 0 packet-length payload-length packet)))
|
(finish-packet 0 packet-length payload-length packet)))
|
||||||
|
|
||||||
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
(define (finish-packet mac-byte-count packet-length payload-length packet)
|
||||||
|
@ -351,7 +356,9 @@
|
||||||
[mode `(packet-body ,packet-length
|
[mode `(packet-body ,packet-length
|
||||||
,payload-length
|
,payload-length
|
||||||
,first-block)])
|
,first-block)])
|
||||||
(at-meta-level (cin (tcp-credit remaining-to-read))))
|
(at-meta-level
|
||||||
|
(send-feedback (tcp-channel remote-addr local-addr
|
||||||
|
(tcp-credit remaining-to-read)))))
|
||||||
(check-hmac packet-length payload-length first-block))]
|
(check-hmac packet-length payload-length first-block))]
|
||||||
|
|
||||||
[`(packet-body ,packet-length ,payload-length ,first-block)
|
[`(packet-body ,packet-length ,payload-length ,first-block)
|
||||||
|
@ -369,24 +376,25 @@
|
||||||
(disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
|
(disconnect-with-error/local-info `((expected-hmac ,computed-hmac-bytes)
|
||||||
(actual-hmac ,received-hmac-bytes))
|
(actual-hmac ,received-hmac-bytes))
|
||||||
SSH_DISCONNECT_MAC_ERROR
|
SSH_DISCONNECT_MAC_ERROR
|
||||||
"Corrupt MAC"))])]))
|
"Corrupt MAC"))]))]))
|
||||||
(role (topic-subscriber (inbound-credit (wild)))
|
(endpoint #:subscriber (inbound-credit (wild))
|
||||||
#:state state
|
#:state state
|
||||||
[(inbound-credit amount)
|
[(inbound-credit amount)
|
||||||
|
(let ()
|
||||||
(define new-state (struct-copy ssh-reader-state state
|
(define new-state (struct-copy ssh-reader-state state
|
||||||
[remaining-credit
|
[remaining-credit
|
||||||
(+ amount (ssh-reader-state-remaining-credit state))]))
|
(+ amount (ssh-reader-state-remaining-credit state))]))
|
||||||
(transition new-state
|
(transition new-state
|
||||||
(issue-credit new-state))])
|
(issue-credit new-state)))])
|
||||||
(role (topic-subscriber (new-keys (wild)
|
(endpoint #:subscriber (new-keys (wild)
|
||||||
(wild)
|
(wild)
|
||||||
(wild) (wild)
|
(wild) (wild)
|
||||||
(wild) (wild)
|
(wild) (wild)
|
||||||
(wild) (wild)))
|
(wild) (wild))
|
||||||
#:state state
|
#:state state
|
||||||
[(? new-keys? nk)
|
[(? new-keys? nk)
|
||||||
(transition (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))))))
|
(endpoint #:publisher (inbound-packet (wild) (wild) (wild) (wild)))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Encrypted Packet Output
|
;; Encrypted Packet Output
|
||||||
|
@ -394,11 +402,11 @@
|
||||||
|
|
||||||
(struct ssh-writer-state (config sequence-number) #:prefab)
|
(struct ssh-writer-state (config sequence-number) #:prefab)
|
||||||
|
|
||||||
(define (ssh-writer new-connection-topic)
|
(define (ssh-writer new-conversation)
|
||||||
(define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
|
(match-define (tcp-channel remote-addr local-addr _) new-conversation)
|
||||||
(transition (ssh-writer-state initial-crypto-configuration 0)
|
(transition (ssh-writer-state initial-crypto-configuration 0)
|
||||||
(role (set (topic-subscriber (outbound-packet (wild)))
|
(endpoint #:publisher (outbound-byte-credit (wild)))
|
||||||
(topic-publisher (outbound-byte-credit (wild))))
|
(endpoint #:subscriber (outbound-packet (wild))
|
||||||
#:state (and state
|
#:state (and state
|
||||||
(ssh-writer-state (crypto-configuration cipher
|
(ssh-writer-state (crypto-configuration cipher
|
||||||
cipher-description
|
cipher-description
|
||||||
|
@ -406,6 +414,7 @@
|
||||||
hmac-description)
|
hmac-description)
|
||||||
sequence-number))
|
sequence-number))
|
||||||
[(outbound-packet message)
|
[(outbound-packet message)
|
||||||
|
(let ()
|
||||||
(define pad-block-size (supported-cipher-block-size cipher-description))
|
(define pad-block-size (supported-cipher-block-size cipher-description))
|
||||||
(define encryptor (if cipher cipher values))
|
(define encryptor (if cipher cipher values))
|
||||||
(define payload (ssh-message-encode message))
|
(define payload (ssh-message-encode message))
|
||||||
|
@ -427,15 +436,18 @@
|
||||||
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
|
||||||
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
(define mac-byte-count (bytes-length computed-hmac-bytes))
|
||||||
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
|
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
|
||||||
(at-meta-level (cout encrypted-packet))
|
(at-meta-level
|
||||||
|
(send-message (tcp-channel local-addr remote-addr encrypted-packet)))
|
||||||
(when (positive? mac-byte-count)
|
(when (positive? mac-byte-count)
|
||||||
(at-meta-level (cout computed-hmac-bytes)))
|
(at-meta-level
|
||||||
(send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))])
|
(send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
|
||||||
(role (topic-subscriber (new-keys (wild)
|
(send-message
|
||||||
|
(outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))])
|
||||||
|
(endpoint #:subscriber (new-keys (wild)
|
||||||
(wild)
|
(wild)
|
||||||
(wild) (wild)
|
(wild) (wild)
|
||||||
(wild) (wild)
|
(wild) (wild)
|
||||||
(wild) (wild)))
|
(wild) (wild))
|
||||||
#:state state
|
#:state state
|
||||||
[(? new-keys? nk)
|
[(? new-keys? nk)
|
||||||
(transition
|
(transition
|
||||||
|
|
Loading…
Reference in New Issue