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

Compare commits

merge into: syndicate-lang:main
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
...
pull from: syndicate-lang:marketplace
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

3 Commits
main ... marketplac

Author SHA1 Message Date
Tony Garnock-Jones 253ce502a2 .gitignore 2013-05-10 16:57:22 -04:00
Tony Garnock-Jones 3c0603878f Avoid doubly-nested transition record 2013-04-11 17:36:39 -04:00
Tony Garnock-Jones 9033cd307c First steps to marketplace port 2013-04-11 15:28:07 -04:00
7 changed files with 398 additions and 369 deletions
Show Stats Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
compiled/

12
marketplace-support.rkt Normal file
View File

@ -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))

222
new-server.rkt
View File

@ -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 (newline)
(write `(,marker ,message)) (flush-output)
(newline) (void))
(flush-output) (list
(void)])) (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
#:state state #:let-name endpoint-name
#:on-presence (sequence-actions (transition state) #:state state
(delete-role role-name) #:on-presence (begin (printf "WAIT ENDED: ~v\n" topic)
action ...))) (sequence-actions (transition state
(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))
(check-remote-identification! remote-identification) (begin
(sequence-actions (transition state) (check-remote-identification! remote-identification)
;; First, set the incoming mode to bytes. (sequence-actions (transition state)
(at-meta-level (cin (tcp-mode 'bytes))) ;; First, set the incoming mode to bytes.
;; Then initialise the reader, switching to packet-reading mode. (at-meta-level
(lambda (ignored-state) (ssh-reader new-connection-topic)) (send-feedback (tcp-channel remote-addr local-addr (tcp-mode 'bytes))))
;; Finally, spawn the remaining processes and issue the initial credit to the reader. ;; Then initialise the reader, switching to packet-reading mode.
(spawn (ssh-writer new-connection-topic) (lambda (ignored-state) (ssh-reader new-conversation))
#:exit-signal? #t ;; Finally, spawn the remaining processes and issue the initial credit to the reader.
#:debug-name 'ssh-writer) (spawn #:debug-name 'ssh-writer
;; Wait for the reader and writer get started, then tell #:child (ssh-writer new-conversation)
;; the reader we are ready for a single packet and spawn ;; TODO: canary: #:exit-signal? #t
;; the session manager. )
(wait-for (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)) #:monitor? #t) ;; Wait for the reader and writer get started, then tell
(wait-for (topic-publisher (outbound-packet (wild)) #:monitor? #t) ;; the reader we are ready for a single packet and spawn
(send-message (inbound-credit 1)) ;; the session manager.
(spawn (ssh-session local-identification (printf "BOO\n")
remote-identification (wait-as #:subscriber (inbound-packet (wild) (wild) (wild) (wild))
repl-boot (printf "YAY\n") (flush-output)
'server) (wait-as #:publisher (outbound-packet (wild))
#:exit-signal? #t (printf "ALSO YAY\n") (flush-output)
#:debug-name 'ssh-session))))])))) (send-message (inbound-credit 1))
(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)
@ -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?))
(match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) (let ()
(close-input-port c2s-in) (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state)
(close-output-port c2s-out) (close-input-port c2s-in)
(close-input-port s2c-in) (close-output-port c2s-out)
(close-output-port s2c-out) (close-input-port s2c-in)
(transition state (quit))] (close-output-port s2c-out)
(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))
(close-output-port (repl-instance-state-c2s-out state)) (let ()
;; ^ this signals the repl thread to exit. (close-output-port (repl-instance-state-c2s-out state))
;; Now, wait for it to do so. ;; ^ this signals the repl thread to exit.
(transition state)] ;; Now, wait for it to do so.
(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
(write `(channel outbound ,cname ,m)) (newline) (begin
(void)])))] (write `(channel outbound ,cname ,m)) (newline)
(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

12
os2-support.rkt
View File

@ -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"))

6
ssh-channel.rkt
View File

@ -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)

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 "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,68 +596,70 @@
[(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)
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) (let ()
(define remote-ref (ssh-channel-remote-ref ch)) (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
(match body (define remote-ref (ssh-channel-remote-ref ch))
[(channel-stream-data data-bytes) (match body
;; TODO: split data-bytes into packets if longer than max packet size [(channel-stream-data data-bytes)
(! conn (ssh-msg-channel-data remote-ref data-bytes))] ;; TODO: split data-bytes into packets if longer than max packet size
[(channel-stream-extended-data type data-bytes) (! conn (ssh-msg-channel-data remote-ref data-bytes))]
(! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] [(channel-stream-extended-data type data-bytes)
[(channel-stream-eof) (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))]
(! conn (ssh-msg-channel-eof remote-ref))] [(channel-stream-eof)
[(channel-stream-notify type data-bytes) (! conn (ssh-msg-channel-eof remote-ref))]
(! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] [(channel-stream-notify type data-bytes)
[(channel-stream-request type data-bytes) (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))]
(! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] [(channel-stream-request type data-bytes)
[(channel-stream-open-failure reason description) (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))]
(! (discard-channel cname conn) [(channel-stream-open-failure reason description)
(ssh-msg-channel-open-failure remote-ref reason description #""))])]) (! (discard-channel cname conn)
(role (topic-publisher (channel-message inbound-stream-name (wild))) (ssh-msg-channel-open-failure remote-ref reason description #""))]))])
#:name (list cname 'inbound) (endpoint #:publisher (channel-message inbound-stream-name (wild))
#:state conn #:name (list cname 'inbound)
#:state conn
[(channel-message _ body) [(channel-message _ body)
(define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) (let ()
(define remote-ref (ssh-channel-remote-ref ch)) (define ch (findf (ssh-channel-name=? cname) (connection-channels conn)))
(match body (define remote-ref (ssh-channel-remote-ref ch))
[(channel-stream-config maximum-packet-size extra-data) (match body
(if (channel-name-locally-originated? cname) [(channel-stream-config maximum-packet-size extra-data)
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. (if (channel-name-locally-originated? cname)
(! conn (ssh-msg-channel-open (channel-name-type cname) ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN.
(ssh-channel-local-ref ch) (! conn (ssh-msg-channel-open (channel-name-type cname)
0 (ssh-channel-local-ref ch)
maximum-packet-size 0
extra-data)) maximum-packet-size
;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. extra-data))
(! conn (ssh-msg-channel-open-confirmation remote-ref ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION.
(ssh-channel-local-ref ch) (! conn (ssh-msg-channel-open-confirmation remote-ref
0 (ssh-channel-local-ref ch)
maximum-packet-size 0
extra-data)))] maximum-packet-size
[(channel-stream-credit count) extra-data)))]
(! conn (ssh-msg-channel-window-adjust remote-ref count))] [(channel-stream-credit count)
[(channel-stream-ok) (! conn (ssh-msg-channel-window-adjust remote-ref count))]
(! conn (ssh-msg-channel-success remote-ref))] [(channel-stream-ok)
[(channel-stream-fail) (! conn (ssh-msg-channel-success remote-ref))]
(! conn (ssh-msg-channel-failure remote-ref))])]))) [(channel-stream-fail)
(! 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,15 +731,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-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
(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
@ -859,46 +860,45 @@
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 (transition (connection #f
(lambda (self-pid) base-packet-dispatcher
(transition (connection #f 0
base-packet-dispatcher (rekey-in-seconds-or-bytes -1 -1 0)
0 #f
(rekey-in-seconds-or-bytes -1 -1 0) '()
#f (case session-role ((client) #f) ((server) #t))
'() local-identification-string
(case session-role ((client) #f) ((server) #t)) peer-identification-string
local-identification-string #f
peer-identification-string application-boot)
#f
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
(dispatch-packet sequence-number payload message conn))) (struct-copy connection conn [discard-next-packet? #f]))
(bump-total transfer-size) (dispatch-packet sequence-number payload message conn)))
(send-message (inbound-credit 1)) (bump-total transfer-size)
maybe-rekey)]))) (send-message (inbound-credit 1))
connection?)) maybe-rekey)])))

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 "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,114 +279,122 @@
(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
(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))
(define block-size (supported-cipher-block-size cipher-description)) (let ()
(define first-block-size block-size) (define block-size (supported-cipher-block-size cipher-description))
(define subsequent-block-size (if cipher block-size 1)) (define first-block-size block-size)
(define decryptor (if cipher cipher values)) (define subsequent-block-size (if cipher block-size 1))
(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 (cin (tcp-credit mac-byte-count)))) (at-meta-level
(finish-packet 0 packet-length payload-length packet))) (send-feedback (tcp-channel remote-addr local-addr
(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 (cin (tcp-credit remaining-to-read)))) (at-meta-level
(check-hmac packet-length payload-length first-block))] (send-feedback (tcp-channel remote-addr local-addr
(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"))]))]))
(role (topic-subscriber (inbound-credit (wild))) (endpoint #:subscriber (inbound-credit (wild))
#:state state #:state state
[(inbound-credit amount) [(inbound-credit amount)
(define new-state (struct-copy ssh-reader-state state (let ()
[remaining-credit (define new-state (struct-copy ssh-reader-state state
(+ amount (ssh-reader-state-remaining-credit state))])) [remaining-credit
(transition new-state (+ amount (ssh-reader-state-remaining-credit state))]))
(issue-credit new-state))]) (transition new-state
(role (topic-subscriber (new-keys (wild) (issue-credit new-state)))])
(wild) (endpoint #:subscriber (new-keys (wild)
(wild) (wild) (wild)
(wild) (wild) (wild) (wild)
(wild) (wild))) (wild) (wild)
#:state state (wild) (wild))
#: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,49 +402,53 @@
(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
hmac hmac
hmac-description) hmac-description)
sequence-number)) sequence-number))
[(outbound-packet message) [(outbound-packet message)
(define pad-block-size (supported-cipher-block-size cipher-description)) (let ()
(define encryptor (if cipher cipher values)) (define pad-block-size (supported-cipher-block-size cipher-description))
(define payload (ssh-message-encode message)) (define encryptor (if cipher cipher values))
;; There must be at least 4 bytes of padding, and padding needs to (define payload (ssh-message-encode message))
;; make the packet length a multiple of pad-block-size. ;; There must be at least 4 bytes of padding, and padding needs to
(define unpadded-length (+ 4 ;; length of length ;; make the packet length a multiple of pad-block-size.
1 ;; length of length-of-padding indicator (define unpadded-length (+ 4 ;; length of length
(bit-string-byte-count payload))) 1 ;; length of length-of-padding indicator
(define min-padded-length (+ unpadded-length 4)) (bit-string-byte-count payload)))
(define padded-length (round-up min-padded-length pad-block-size)) (define min-padded-length (+ unpadded-length 4))
(define padding-length (- padded-length unpadded-length)) (define padded-length (round-up min-padded-length pad-block-size))
(define packet-length (- padded-length 4)) ;; the packet length does *not* include itself! (define padding-length (- padded-length unpadded-length))
(define packet (bit-string->bytes (define packet-length (- padded-length 4)) ;; the packet length does *not* include itself!
(bit-string (packet-length :: integer bits 32) (define packet (bit-string->bytes
(padding-length :: integer bits 8) (bit-string (packet-length :: integer bits 32)
(payload :: binary) (padding-length :: integer bits 8)
((random-bytes padding-length) :: binary)))) (payload :: binary)
(define encrypted-packet (encryptor packet)) ((random-bytes padding-length) :: binary))))
(define computed-hmac-bytes (apply-hmac hmac sequence-number packet)) (define encrypted-packet (encryptor packet))
(define mac-byte-count (bytes-length computed-hmac-bytes)) (define computed-hmac-bytes (apply-hmac hmac sequence-number packet))
(transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)]) (define mac-byte-count (bytes-length computed-hmac-bytes))
(at-meta-level (cout encrypted-packet)) (transition (struct-copy ssh-writer-state state [sequence-number (+ sequence-number 1)])
(when (positive? mac-byte-count) (at-meta-level
(at-meta-level (cout computed-hmac-bytes))) (send-message (tcp-channel local-addr remote-addr encrypted-packet)))
(send-message (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count))))]) (when (positive? mac-byte-count)
(role (topic-subscriber (new-keys (wild) (at-meta-level
(wild) (send-message (tcp-channel local-addr remote-addr computed-hmac-bytes))))
(wild) (wild) (send-message
(wild) (wild) (outbound-byte-credit (+ (bytes-length encrypted-packet) mac-byte-count)))))])
(wild) (wild))) (endpoint #:subscriber (new-keys (wild)
#:state state (wild)
(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)]))])))