syndicate-lang
/
racket-ssh-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: syndicate-lang:pre-cleanup-for-github
Branches Tags
syndicate-lang:main
syndicate-lang:cleanup-for-github
syndicate-lang:marketplace
syndicate-lang:typed-kernel
syndicate-lang:moved-to-github
syndicate-lang:pre-cleanup-for-github
syndicate-lang:pre-typed-kernel
syndicate-lang:pre-os2
syndicate-lang:pre-os-big-bang
..
compare: syndicate-lang:main
Branches Tags
syndicate-lang:cleanup-for-github
syndicate-lang:marketplace
syndicate-lang:main
syndicate-lang:typed-kernel
syndicate-lang:moved-to-github
syndicate-lang:pre-cleanup-for-github
syndicate-lang:pre-typed-kernel
syndicate-lang:pre-os2
syndicate-lang:pre-os-big-bang

No commits in common. "pre-cleanup-for-github" and "main" have entirely different histories.
pre-cleanu ... main

6 changed files with 369 additions and 397 deletions
Show Stats Expand all files Collapse all files

12
marketplace-support.rkt
View File

@ -1,12 +0,0 @@
#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))

222
new-server.rkt
View File

@ -14,20 +14,22 @@
(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 "marketplace-support.rkt") (require "os2-support.rkt")
(define (main) (define (main)
(ground-vm (timer-driver) (ground-vm
(tcp-driver) (transition 'no-state
(tcp-spy) (spawn (timer-driver 'timer-driver))
(spawn #:debug-name 'ssh-tcp-listener #:child listener))) ;; PAPER NOTE: remove #:debug-name for presentation economy
(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
(endpoint #:subscriber (tcp-channel ? (tcp-listener 2322) ?) (role (tcp-listener 2322)
#:observer #:topic t
#:conversation r #:on-presence (spawn (session-vm t) #:debug-name (debug-name 'ssh-session-vm t)))))
#:on-presence (session-vm r))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
@ -43,81 +45,59 @@
peer-identification-string))) peer-identification-string)))
(define (spy marker) (define (spy marker)
(define (dump what message) (role (or (topic-subscriber (wild) #:monitor? #t)
(write `(,marker ,what ,message)) (topic-publisher (wild) #:monitor? #t))
(newline) [message
(flush-output) (write `(,marker ,message))
(void)) (newline)
(list (flush-output)
(endpoint #:subscriber (wild) #:everything (void)]))
#: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-as my-orientation topic action ...) (define-syntax-rule (wait-for topic-of-interest action ...)
(endpoint my-orientation topic #:observer (role/fresh role-name topic-of-interest
#: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-conversation) (define (session-vm new-connection-topic)
(match-define (tcp-channel remote-addr local-addr _) new-conversation) (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
(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 (at-meta-level (cout (bytes-append local-identification #"\r\n"))))
(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
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?) (role in-topic
#: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 ;; Then initialise the reader, switching to packet-reading mode.
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes)))) (lambda (ignored-state) (ssh-reader new-connection-topic))
;; Then initialise the reader, switching to packet-reading mode. ;; Finally, spawn the remaining processes and issue the initial credit to the reader.
(lambda (ignored-state) (ssh-reader new-conversation)) (spawn (ssh-writer new-connection-topic)
;; Finally, spawn the remaining processes and issue the initial credit to the reader. #:exit-signal? #t
(spawn #:debug-name 'ssh-writer #:debug-name 'ssh-writer)
#:child (ssh-writer new-conversation) ;; Wait for the reader and writer get started, then tell
;; TODO: canary: #:exit-signal? #t ;; the reader we are ready for a single packet and spawn
) ;; the session manager.
;; Wait for the reader and writer get started, then tell (wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t)
;; the reader we are ready for a single packet and spawn (wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t)
;; the session manager. (send-message (inbound-credit 1))
(printf "BOO\n") (spawn (ssh-session local-identification
(wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild)) remote-identification
(printf "YAY\n") (flush-output) repl-boot
(wait-as #:publisher (outbound-packet (wild)) 'server)
(printf "ALSO YAY\n") (flush-output) #:exit-signal? #t
(send-message (inbound-credit 1)) #:debug-name 'ssh-session))))]))))
(spawn #:debug-name 'ssh-session
#:pid session-pid
#:child (ssh-session session-pid
local-identification
remote-identification
repl-boot
'server)
;; TODO: canary: #:exit-signal? #t
)))))]))))
(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)
@ -143,43 +123,44 @@
(define (inert-exception-handler reason) (define (inert-exception-handler reason)
inert-exception-handler) inert-exception-handler)
(nested-vm #:debug-name (list 'ssh-session-vm new-conversation) (nested-vm #:debug-name (debug-name 'ssh-session-vm new-connection-topic)
(event-relay 'ssh-event-relay) (transition 'no-state
(timer-relay 'ssh-timer-relay) (spawn event-relay #:debug-name (debug-name 'session-event-relay))
(spy 'SSH) (spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
(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 (at-meta-level (cin (tcp-mode 'lines)))
(send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'lines))) (at-meta-level (cin (tcp-credit 1)))
(send-feedback (tcp-channel remote-addr local-addr (tcp-credit 1))))
(spawn #:debug-name 'ssh-reader (spawn (read-handshake-and-become-reader)
#:child (read-handshake-and-become-reader) #:exit-signal? #t
;; TODO: canary: #:exit-signal? #t #:debug-name 'ssh-reader)
)
;; TODO: canary: (spawn (transition active-exception-handler
;; (spawn #:child (role (topic-subscriber (exit-signal (wild) (wild)))
;; (transition active-exception-handler #:state current-handler
;; (role (topic-subscriber (exit-signal (wild) (wild))) #:reason reason
;; #:state current-handler #:on-absence (current-handler reason)))))))
;; #:reason reason
;; #:on-absence (current-handler reason))))
))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(define (repl-boot user-name) (define (repl-boot user-name)
(list (transition 'no-repl-state
(event-relay 'app-event-relay) (spawn event-relay #:debug-name (debug-name 'repl-event-relay))
(spy 'APP) (spy 'APP)
(at-meta-level (at-meta-level
(endpoint #:subscriber (channel-message (channel-stream-name #t (wild)) (wild)) (role (topic-subscriber (channel-message (channel-stream-name #t (wild)) (wild)))
#:conversation (channel-message (channel-stream-name _ cname) _) #:state state
#:on-presence (spawn #:debug-name cname #:child (repl-instance user-name cname)))))) #:topic t
#: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
@ -212,9 +193,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))
(endpoint #:subscriber (cons (thread-dead-evt repl-thread) (wild)) (role (topic-subscriber (cons (thread-dead-evt repl-thread) (wild)))
[_ (quit #:reason "REPL thread exited")]) [_ (quit #:reason "REPL thread exited")])
(endpoint #:subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)) (role (topic-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
@ -223,24 +204,22 @@
;; 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))
@ -255,7 +234,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
(endpoint #:subscriber (channel-message inbound-stream (wild)) (role (topic-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
@ -265,13 +244,12 @@
[(channel-message _ body) [(channel-message _ body)
(handle-channel-message state body)])) (handle-channel-message state body)]))
(at-meta-level (at-meta-level
(endpoint #:publisher (channel-message outbound-stream (wild)) (role (topic-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-state (transition 'no-instance-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

12
os2-support.rkt Normal file
View File

@ -0,0 +1,12 @@
#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"))

6
ssh-channel.rkt
View File

@ -3,6 +3,12 @@
(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)

242
ssh-session.rkt
View File

@ -16,7 +16,7 @@
(require "ssh-transport.rkt") (require "ssh-transport.rkt")
(require "ssh-channel.rkt") (require "ssh-channel.rkt")
(require "marketplace-support.rkt") (require "os2-support.rkt")
(provide rekey-interval (provide rekey-interval
rekey-volume rekey-volume
@ -495,9 +495,10 @@
conn)))) conn))))
(lambda (conn) (lambda (conn)
(transition conn (transition conn
;; TODO: canary for NESTED VM!: #:exit-signal? #t (spawn (nested-vm #:debug-name 'ssh-application-vm
(nested-vm #:debug-name 'ssh-application-vm ((connection-application-boot conn) user-name))
((connection-application-boot conn) user-name)))))] #:exit-signal? #t
#: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))))]))
@ -596,70 +597,68 @@
[(remote) [(remote)
(case old-close-state (case old-close-state
[(neither local) [(neither local)
(list (delete-endpoint (list cname 'outbound)) (list (delete-role (list cname 'outbound))
(delete-endpoint (list cname 'inbound)))] (delete-role (list cname 'inbound)))]
[else (list)])])))] [else (list)])])))]
[else (transition conn)])) [else (transition conn)]))
(define (channel-endpoints cname initial-message-producer) (define (channel-roles 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
(endpoint #:subscriber (channel-message outbound-stream-name (wild)) (role (topic-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 [(channel-stream-data data-bytes)
[(channel-stream-data data-bytes) ;; TODO: split data-bytes into packets if longer than max packet size
;; TODO: split data-bytes into packets if longer than max packet size (! conn (ssh-msg-channel-data remote-ref data-bytes))]
(! conn (ssh-msg-channel-data remote-ref data-bytes))] [(channel-stream-extended-data type data-bytes)
[(channel-stream-extended-data type data-bytes) (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] [(channel-stream-eof)
[(channel-stream-eof) (! conn (ssh-msg-channel-eof remote-ref))]
(! conn (ssh-msg-channel-eof remote-ref))] [(channel-stream-notify type data-bytes)
[(channel-stream-notify type data-bytes) (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] [(channel-stream-request type data-bytes)
[(channel-stream-request type data-bytes) (! 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 [(channel-stream-config maximum-packet-size extra-data)
[(channel-stream-config maximum-packet-size extra-data) (if (channel-name-locally-originated? cname)
(if (channel-name-locally-originated? cname) ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. (! conn (ssh-msg-channel-open (channel-name-type cname)
(! conn (ssh-msg-channel-open (channel-name-type cname) (ssh-channel-local-ref ch)
(ssh-channel-local-ref ch) 0
0 maximum-packet-size
maximum-packet-size extra-data))
extra-data)) ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. (! conn (ssh-msg-channel-open-confirmation remote-ref
(! conn (ssh-msg-channel-open-confirmation remote-ref (ssh-channel-local-ref ch)
(ssh-channel-local-ref ch) 0
0 maximum-packet-size
maximum-packet-size extra-data)))]
extra-data)))] [(channel-stream-credit count)
[(channel-stream-credit count) (! conn (ssh-msg-channel-window-adjust remote-ref count))]
(! conn (ssh-msg-channel-window-adjust remote-ref count))] [(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
@ -671,15 +670,11 @@
;; 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
@ -699,16 +694,20 @@
;; 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.
(endpoint #:publisher (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) (role (set (topic-publisher arbitrary-locally-originated-traffic #:monitor? #t)
#:observer (topic-subscriber arbitrary-locally-originated-traffic #:monitor? #t))
#:state conn #:state conn
#:conversation (channel-message (channel-stream-name #t cname) _) #:topic t
#:on-presence (respond-to-opened-outbound-channel conn cname)) #:on-presence
(endpoint #:subscriber (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) (match t
#:observer [(or (topic 'publisher (channel-message (channel-stream-name #f cname) _) #f)
#:state conn (topic 'subscriber (channel-message (channel-stream-name #t cname) _) #f))
#:conversation (channel-message (channel-stream-name #f cname) _) (if (and (ground? cname)
#:on-presence (respond-to-opened-outbound-channel conn cname)))) (not (memf (ssh-channel-name=? cname) (connection-channels conn))))
(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*
@ -731,15 +730,15 @@
(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-endpoints cname (channel-roles 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
(channel-stream-config maximum-packet-size (channel-stream-config maximum-packet-size
extra-request-data))) extra-request-data)))
(send-feedback (send-feedback
(channel-message outbound-stream (channel-message outbound-stream
(channel-stream-credit initial-window-size)))))))) (channel-stream-credit initial-window-size))))))))
(define (handle-msg-channel-open-confirmation packet message conn) (define (handle-msg-channel-open-confirmation packet message conn)
(match-define (ssh-msg-channel-open-confirmation local-ref (match-define (ssh-msg-channel-open-confirmation local-ref
@ -860,45 +859,46 @@
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 self-pid (define (ssh-session local-identification-string
local-identification-string
peer-identification-string peer-identification-string
application-boot application-boot
session-role) session-role)
(transition (connection #f (boot-specification
base-packet-dispatcher (lambda (self-pid)
0 (transition (connection #f
(rekey-in-seconds-or-bytes -1 -1 0) base-packet-dispatcher
#f 0
'() (rekey-in-seconds-or-bytes -1 -1 0)
(case session-role ((client) #f) ((server) #t)) #f
local-identification-string '()
peer-identification-string (case session-role ((client) #f) ((server) #t))
#f local-identification-string
application-boot) peer-identification-string
#f
application-boot)
(endpoint #:subscriber (timer-expired 'rekey-timer (wild)) (role (topic-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)])
(endpoint #:subscriber (outbound-byte-credit (wild)) (role (topic-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)])
(endpoint #:subscriber (inbound-packet (wild) (wild) (wild) (wild)) (role (topic-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 (transition (struct-copy connection conn [discard-next-packet? #f]))
(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?))

272
ssh-transport.rkt
View File

@ -14,7 +14,7 @@
(require "ssh-message-types.rkt") (require "ssh-message-types.rkt")
(require "ssh-exceptions.rkt") (require "ssh-exceptions.rkt")
(require "marketplace-support.rkt") (require "os2-support.rkt")
(provide (struct-out inbound-packet) (provide (struct-out inbound-packet)
(struct-out inbound-credit) (struct-out inbound-credit)
@ -279,122 +279,114 @@
(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-conversation) (define (ssh-reader new-connection-topic)
(match-define (tcp-channel remote-addr local-addr _) new-conversation) (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
(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 (at-meta-level (cin (tcp-credit (supported-cipher-block-size desc))))))
(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
(endpoint #:subscriber (tcp-channel remote-addr local-addr ?) (role in-topic
#:name 'socket-reader #:name 'socket-reader
#:state (and state #:state (and state
(ssh-reader-state mode (ssh-reader-state mode
(crypto-configuration cipher (crypto-configuration cipher
cipher-description cipher-description
hmac hmac
hmac-description) hmac-description)
sequence-number sequence-number
remaining-credit)) remaining-credit))
[(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)) (define decryptor (if cipher cipher values))
(define decryptor (if cipher cipher values))
(define (check-hmac packet-length payload-length packet) (define (check-hmac packet-length payload-length packet)
(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))
(if (positive? mac-byte-count) (if (positive? mac-byte-count)
(transition (struct-copy ssh-reader-state state (transition (struct-copy ssh-reader-state state
[mode `(packet-hmac ,computed-hmac-bytes [mode `(packet-hmac ,computed-hmac-bytes
,mac-byte-count ,mac-byte-count
,packet-length ,packet-length
,payload-length ,payload-length
,packet)]) ,packet)])
(at-meta-level (at-meta-level (cin (tcp-credit mac-byte-count))))
(send-feedback (tcp-channel remote-addr local-addr (finish-packet 0 packet-length payload-length packet)))
(tcp-credit mac-byte-count)))))
(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)
(define bytes-read (+ packet-length mac-byte-count)) (define bytes-read (+ packet-length mac-byte-count))
(define payload (subbytes packet 5 (+ 5 payload-length))) (define payload (subbytes packet 5 (+ 5 payload-length)))
(define new-credit (- remaining-credit 1)) (define new-credit (- remaining-credit 1))
(define new-state (struct-copy ssh-reader-state state (define new-state (struct-copy ssh-reader-state state
[mode 'packet-header] [mode 'packet-header]
[sequence-number (+ sequence-number 1)] [sequence-number (+ sequence-number 1)]
[remaining-credit new-credit])) [remaining-credit new-credit]))
(transition new-state (transition new-state
(issue-credit new-state) (issue-credit new-state)
(send-message (send-message
(inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read)))) (inbound-packet sequence-number payload (ssh-message-decode payload) bytes-read))))
(match mode (match mode
['packet-header ['packet-header
(define decrypted-packet (decryptor encrypted-packet)) (define decrypted-packet (decryptor encrypted-packet))
(define first-block decrypted-packet) (define first-block decrypted-packet)
(define packet-length (integer-bytes->integer first-block #f #t 0 4)) (define packet-length (integer-bytes->integer first-block #f #t 0 4))
(check-packet-length! packet-length packet-size-limit subsequent-block-size) (check-packet-length! packet-length packet-size-limit subsequent-block-size)
(define padding-length (bytes-ref first-block 4)) (define padding-length (bytes-ref first-block 4))
(define payload-length (- packet-length padding-length 1)) (define payload-length (- packet-length padding-length 1))
(define amount-of-packet-in-first-block (define amount-of-packet-in-first-block
(- (bytes-length first-block) 4)) ;; not incl length (- (bytes-length first-block) 4)) ;; not incl length
(define remaining-to-read (- packet-length amount-of-packet-in-first-block)) (define remaining-to-read (- packet-length amount-of-packet-in-first-block))
(if (positive? remaining-to-read) (if (positive? remaining-to-read)
(transition (struct-copy ssh-reader-state state (transition (struct-copy ssh-reader-state state
[mode `(packet-body ,packet-length [mode `(packet-body ,packet-length
,payload-length ,payload-length
,first-block)]) ,first-block)])
(at-meta-level (at-meta-level (cin (tcp-credit remaining-to-read))))
(send-feedback (tcp-channel remote-addr local-addr (check-hmac packet-length payload-length first-block))]
(tcp-credit remaining-to-read)))))
(check-hmac packet-length payload-length first-block))]
[`(packet-body ,packet-length ,payload-length ,first-block) [`(packet-body ,packet-length ,payload-length ,first-block)
(define decrypted-packet (decryptor encrypted-packet)) (define decrypted-packet (decryptor encrypted-packet))
(check-hmac packet-length payload-length (bytes-append first-block decrypted-packet))] (check-hmac packet-length payload-length (bytes-append first-block decrypted-packet))]
[`(packet-hmac ,computed-hmac-bytes [`(packet-hmac ,computed-hmac-bytes
,mac-byte-count ,mac-byte-count
,packet-length ,packet-length
,payload-length ,payload-length
,main-packet) ,main-packet)
(define received-hmac-bytes encrypted-packet) ;; not really encrypted! (define received-hmac-bytes encrypted-packet) ;; not really encrypted!
(if (equal? computed-hmac-bytes received-hmac-bytes) (if (equal? computed-hmac-bytes received-hmac-bytes)
(finish-packet mac-byte-count packet-length payload-length main-packet) (finish-packet mac-byte-count packet-length payload-length main-packet)
(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"))])]))
(endpoint #:subscriber (inbound-credit (wild)) (role (topic-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)]))])
(endpoint #:publisher (inbound-packet (wild) (wild) (wild) (wild))))) (role (topic-publisher (inbound-packet (wild) (wild) (wild) (wild))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Encrypted Packet Output ;; Encrypted Packet Output
@ -402,53 +394,49 @@
(struct ssh-writer-state (config sequence-number) #:prefab) (struct ssh-writer-state (config sequence-number) #:prefab)
(define (ssh-writer new-conversation) (define (ssh-writer new-connection-topic)
(match-define (tcp-channel remote-addr local-addr _) new-conversation) (define-values (cin cout in-topic out-topic) (topic->tcp-connection new-connection-topic))
(transition (ssh-writer-state initial-crypto-configuration 0) (transition (ssh-writer-state initial-crypto-configuration 0)
(endpoint #:publisher (outbound-byte-credit (wild))) (role (set (topic-subscriber (outbound-packet (wild)))
(endpoint #:subscriber (outbound-packet (wild)) (topic-publisher (outbound-byte-credit (wild))))
#:state (and state #:state (and state
(ssh-writer-state (crypto-configuration cipher (ssh-writer-state (crypto-configuration cipher
cipher-description cipher-description
hmac hmac
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)) ;; There must be at least 4 bytes of padding, and padding needs to
;; There must be at least 4 bytes of padding, and padding needs to ;; make the packet length a multiple of pad-block-size.
;; make the packet length a multiple of pad-block-size. (define unpadded-length (+ 4 ;; length of length
(define unpadded-length (+ 4 ;; length of length 1 ;; length of length-of-padding indicator
1 ;; length of length-of-padding indicator (bit-string-byte-count payload)))
(bit-string-byte-count payload))) (define min-padded-length (+ unpadded-length 4))
(define min-padded-length (+ unpadded-length 4)) (define padded-length (round-up min-padded-length pad-block-size))
(define padded-length (round-up min-padded-length pad-block-size)) (define padding-length (- padded-length unpadded-length))
(define padding-length (- padded-length unpadded-length)) (define packet-length (- padded-length 4)) ;; the packet length does *not* include itself!
(define packet-length (- padded-length 4)) ;; the packet length does *not* include itself! (define packet (bit-string->bytes
(define packet (bit-string->bytes (bit-string (packet-length :: integer bits 32)
(bit-string (packet-length :: integer bits 32) (padding-length :: integer bits 8)
(padding-length :: integer bits 8) (payload :: binary)
(payload :: binary) ((random-bytes padding-length) :: binary))))
((random-bytes padding-length) :: binary)))) (define encrypted-packet (encryptor packet))
(define encrypted-packet (encryptor packet)) (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 (when (positive? mac-byte-count)
(send-message (tcp-channel local-addr remote-addr encrypted-packet))) (at-meta-level (cout computed-hmac-bytes)))
(when (positive? mac-byte-count) (send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))])
(at-meta-level (role (topic-subscriber (new-keys (wild)
(send-message (tcp-channel local-addr remote-addr computed-hmac-bytes)))) (wild)
(send-message (wild) (wild)
(outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))]) (wild) (wild)
(endpoint #:subscriber (new-keys (wild) (wild) (wild)))
(wild) #:state state
(wild) (wild)
(wild) (wild)
(wild) (wild))
#:state state
[(? new-keys? nk) [(? new-keys? nk)
(transition (transition
(struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))]))) (struct-copy ssh-writer-state state [config (apply-negotiated-options nk #t)]))])))