From 9e7fc9bbbd37fb5125a7c3544454ab63468316c4 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 19 Jun 2012 17:28:24 -0400 Subject: [PATCH] Channel demux and management from the SSH side. --- ssh-channel.rkt | 61 ++++++--- ssh-session.rkt | 335 +++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 372 insertions(+), 24 deletions(-) diff --git a/ssh-channel.rkt b/ssh-channel.rkt index 443b7ec..450f268 100644 --- a/ssh-channel.rkt +++ b/ssh-channel.rkt @@ -10,6 +10,11 @@ (require "os2-support.rkt") (provide (struct-out ssh-channel) + + (struct-out channel-name) + (struct-out channel-stream-name) + (struct-out channel-message) + (struct-out channel-stream-credit) (struct-out channel-stream-data) (struct-out channel-stream-extended-data) @@ -17,7 +22,9 @@ (struct-out channel-stream-notify) (struct-out channel-stream-request) (struct-out channel-stream-ok) - (struct-out channel-stream-fail)) + (struct-out channel-stream-fail) + (struct-out channel-stream-config) + (struct-out channel-stream-open-failure)) ;; A CloseState is one of ;; - 'neither, indicating that neither side has signalled closure @@ -35,38 +42,44 @@ ;; \/ \/ ;; 'both +;; TODO: Once the presence-based routing table can be queried, the +;; CloseState becomes redundant, because we can just ask which roles +;; remain to decide whether either direction is still open. + ;; A ChannelState is a (ssh-channel ...) TODO ;; Named ssh-channel to avoid conflicts with Racket's built-in ;; synchronous channels. -(struct ssh-channel (my-ref ;; Uint32 - your-ref ;; Maybe - type ;; String - continuations ;; TransactionManager (see ordered-rpc.rkt) - outbound-window ;; Maybe +(struct ssh-channel (name ;; ChannelName + local-ref ;; Uint32 + remote-ref ;; Maybe outbound-packet-size ;; Maybe - inbound-window ;; Natural - eof-state ;; CloseState covering EOF signals close-state ;; CloseState covering CLOSE signals ) #:transparent) +;; ChannelName = (channel-name Boolean Bytes Any) +;; Names a channel within a connection. Unique within a particular +;; connection. If (locally-originated?) is true, then the local peer +;; is the one that opened this channel, and the local peer is +;; reponsible for choosing the (identifier) and ensuring that it is +;; unique with respect to other locally-originated streams within this +;; connection; if false, the remote peer opened the channel, and the +;; (identifier) is chosen managed by the connection-control code. If +;; (locally-originated?) is true, the (type) is chosen by the local +;; peer, otherwise it is chosen by the remote peer. +(struct channel-name (locally-originated? type identifier) #:prefab) + +;; ChannelStreamName = (channel-stream-name Boolean ChannelName) +;; Names a stream within a channel within a connection. If (inbound?) +;; is true, this is the stream of packets from the remote peer to the +;; local peer; if false, the reverse. +(struct channel-stream-name (inbound? channel) #:prefab) + ;; ChannelMessage = (channel-message ChannelStreamName ChannelMessageBody) ;; Relates a message to a particular stream within a channel within a ;; connection. (struct channel-message (stream-name body) #:prefab) -;; ChannelStreamName = (channel-stream-name Boolean Boolean Any) -;; Names a stream within a channel within a connection. Unique within -;; a particular connection. If (inbound?) is true, this is the stream -;; of packets from the remote peer to the local peer; if false, the -;; reverse. If (locally-originated?) is true, then the local peer is -;; the one that opened this channel, and the local peer is reponsible -;; for choosing the (identifier) and ensuring that it is unique with -;; respect to other locally-originated streams within this connection; -;; if false, the remote peer opened the channel, and the (identifier) -;; is chosen managed by the connection-control code. -(struct channel-stream-name (inbound? locally-originated? identifier) #:prefab) - ;; A ChannelMessageBody is one of ;; -- (channel-stream-credit NonNegativeInteger) ** ;; Informs the publisher that it may transmit another (count) @@ -88,6 +101,12 @@ ;; RPC SSH_MSG_CHANNEL_REQUEST reply. ;; -- (channel-stream-fail) ** ;; RPC SSH_MSG_CHANNEL_REQUEST error. +;; -- (channel-stream-config Uint32 Bytes) ** +;; Either SSH_MSG_CHANNEL_OPEN or +;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION, depending on direction of +;; travel. Must be sent before any channel-stream-credit messages. +;; -- (channel-stream-open-failure Uint32 Bytes) +;; SSH_MSG_CHANNEL_OPEN_FAILURE. ;; ;; Messages marked ** travel "upstream", from subscriber to publisher. (struct channel-stream-credit (count) #:prefab) @@ -98,3 +117,5 @@ (struct channel-stream-request (type bytes) #:prefab) (struct channel-stream-ok () #:prefab) (struct channel-stream-fail () #:prefab) +(struct channel-stream-config (maximum-packet-size extra-data) #:prefab) +(struct channel-stream-open-failure (reason description) #:prefab) diff --git a/ssh-session.rkt b/ssh-session.rkt index 796987c..ef4ab0a 100644 --- a/ssh-session.rkt +++ b/ssh-session.rkt @@ -54,6 +54,12 @@ ;; cryptographic operations on the received bytes are mandated by the ;; protocol. +;; TODO: Remove dispatch-table in favour of using the os2 subscription +;; mechanism to dispatch packets. I could do this now, but I'd lose +;; SSH_MSG_UNIMPLEMENTED support: I would need to be able to query the +;; current routing table to see whether there was an active listener +;; ready to take a given packet. + ;; A ConnectionState is a (connection ... TODO fix this) representing ;; the complete state of the SSH transport, authentication, and ;; connection layers. @@ -62,7 +68,7 @@ total-transferred rekey-state authentication-state - channel-map + channels ;; ListOf is-server? local-id remote-id @@ -482,9 +488,330 @@ (transition conn (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) -;; SKETCH-O +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Channel management +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (unused-local-channel-ref conn) + (define (bump-candidate candidate) + (modulo (+ candidate 1) #x100000000)) + (define first-candidate (match (connection-channels conn) + ['() 0] + [(cons ch _) (bump-candidate (ssh-channel-local-ref ch))])) + (let examine-candidate ((candidate first-candidate)) + (let loop ((chs (connection-channels conn))) + (cond + [(null? chs) candidate] + [(= (ssh-channel-local-ref (car chs)) candidate) + (examine-candidate (bump-candidate candidate))] + [else (loop (cdr chs))])))) + +(define (replacef proc updater creator lst) + (let loop ((lst lst)) + (cond [(null? lst) (list (creator))] + [(proc (car lst)) (cons (updater (car lst)) (cdr lst))] + [else (cons (car lst) (loop (cdr lst)))]))) + +(define (remf proc lst) + (cond [(null? lst) '()] + [(proc (car lst)) (cdr lst)] + [else (cons (car lst) (remf proc (cdr lst)))])) + +;; ChannelName -> ChannelState -> Boolean +(define ((ssh-channel-name=? cname) c) + (equal? (ssh-channel-name c) cname)) + +;; Connection Uint32 -> ChannelState +(define (get-channel conn local-ref) + (define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref)) + (connection-channels conn))) + (when (not ch) + (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR + "Attempt to use known channel local-ref ~v" + local-ref)) + ch) + +;; ChannelName Maybe Connection -> Connection +(define (update-channel cname updater conn) + (struct-copy connection conn + [channels + (replacef (ssh-channel-name=? cname) + updater + (lambda () (updater (ssh-channel cname + (unused-local-channel-ref conn) + #f + #f + 'neither))) + (connection-channels conn))])) + +;; ChannelName Connection -> Connection +(define (discard-channel cname conn) + (struct-copy connection conn + [channels + (remf (ssh-channel-name=? cname) (connection-channels conn))])) + +;; CloseState Either<'local,'remote> -> CloseState +(define (update-close-state old-state action) + (define local? (case action ((local) #t) ((remote) #f))) + (case old-state + ((neither) (if local? 'local 'remote)) + ((local) (if local? 'local 'both)) + ((remote) (if local? 'both 'remote)) + ((both) 'both))) + +(define (maybe-close-channel cname conn action) + (cond + [(findf (ssh-channel-name=? cname) (connection-channels conn)) => + (lambda (ch) + (define old-close-state (ssh-channel-close-state ch)) + (define new-close-state (update-close-state old-close-state action)) + (transition (if (eq? new-close-state 'both) + (discard-channel ch conn) + (update-channel cname + (lambda (ch) + (struct-copy ssh-channel ch + [close-state new-close-state])) + conn)) + (case action + [(local) + (case old-close-state + [(neither remote) + (list (send-message (outbound-packet + (ssh-msg-channel-close (ssh-channel-remote-ref ch)))))] + [else (list)])] + [(remote) + (case old-close-state + [(neither local) + (list (delete-role (list cname 'outbound)) + (delete-role (list cname 'inbound)))] + [else (list)])])))] + [else conn])) + +(define (channel-roles cname initial-message-producer) + (define inbound-stream-name (channel-stream-name #t cname)) + (define outbound-stream-name (channel-stream-name #f cname)) + (define (! conn message) + (transition conn (send-message (outbound-packet message)))) + (list + (role (list cname 'outbound) (topic-subscriber (channel-message outbound-stream-name (wild))) + #:state conn + #:on-presence + (transition conn + (initial-message-producer inbound-stream-name outbound-stream-name)) + #:on-absence + (maybe-close-channel cname conn 'local) + [(channel-message _ body) + (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) + (define remote-ref (ssh-channel-remote-ref ch)) + (match body + [(channel-stream-data data-bytes) + ;; TODO: split data-bytes into packets if longer than max packet size + (! conn (ssh-msg-channel-data remote-ref data-bytes))] + [(channel-stream-extended-data type data-bytes) + (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] + [(channel-stream-eof) + (! conn (ssh-msg-channel-eof remote-ref))] + [(channel-stream-notify type data-bytes) + (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] + [(channel-stream-request type data-bytes) + (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] + [(channel-stream-open-failure reason description) + (! (discard-channel cname conn) + (ssh-msg-channel-open-failure remote-ref reason description #""))])]) + (role (list cname 'inbound) (topic-publisher (channel-message inbound-stream-name (wild))) + #:state conn + [(channel-message _ body) + (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) + (define remote-ref (ssh-channel-remote-ref ch)) + (match body + [(channel-stream-config maximum-packet-size extra-data) + (if (channel-name-locally-originated? cname) + ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. + (! conn (ssh-msg-channel-open (channel-name-type cname) + (ssh-channel-local-ref ch) + 0 + (default-packet-limit) + extra-data)) + ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. + (! conn (ssh-msg-channel-open-confirmation remote-ref + (ssh-channel-local-ref ch) + 0 + (default-packet-limit) + extra-data)))] + [(channel-stream-credit count) + (! conn (ssh-msg-channel-window-adjust remote-ref count))] + [(channel-stream-ok) + (! conn (ssh-msg-channel-success remote-ref))] + [(channel-stream-fail) + (! conn (ssh-msg-channel-failure remote-ref))])]))) + +(define (channel-notify conn ch inbound? body) + (transition conn + (send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch)) + body) + (if inbound? 'publisher 'subscriber)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Connection service +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define (start-connection-service conn) - 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))) + (extend-transition + (set-handlers conn + ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request + SSH_MSG_CHANNEL_OPEN handle-msg-channel-open + SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation + SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure + SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust + SSH_MSG_CHANNEL_DATA handle-msg-channel-data + SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data + SSH_MSG_CHANNEL_EOF handle-msg-channel-eof + SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close + SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request + SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success + SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure) + ;; Start responding to channel interest coming from the + ;; application. We are responding to channels appearing from the + ;; remote peer by virtue of our installation of the handler for + ;; SSH_MSG_CHANNEL_OPEN above. + (role 'channel-connector + (set (topic-publisher arbitrary-locally-originated-traffic #:virtual? #t) + (topic-subscriber arbitrary-locally-originated-traffic #:virtual? #t)) + #:state conn + #:topic t + #:on-presence + (match t + [(topic _ _ #t) + ;; Virtual topics appearing indicate receptivity to incoming + ;; channels, and are nothing to do with outgoing channels. + conn] + [(or (topic 'publisher (channel-message (channel-stream-name #f cname) _) #f) + (topic 'subscriber (channel-message (channel-stream-name #t cname) _) #f)) + (if (and (ground? cname) + (not (memf (ssh-channel-name=? cname) (connection-channels conn)))) + (transition (update-channel cname values conn) + (channel-roles cname (lambda (inbound-stream outbound-stream) + '()))) + conn)])))) + +(define (handle-msg-channel-open packet message conn) + (match-define (ssh-msg-channel-open channel-type* + remote-ref + initial-window-size + maximum-packet-size + extra-request-data*) + message) + + (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref)) + (connection-channels conn)) + (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR + "Attempt to open already-open channel ~v" + remote-ref)) + + (define channel-type (bit-string->bytes channel-type*)) + (define extra-request-data (bit-string->bytes extra-request-data*)) + (define cname (channel-name #f channel-type remote-ref)) + + (transition (update-channel cname + (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref])) + conn) + (channel-roles cname + (lambda (inbound-stream outbound-stream) + (list (send-message + (channel-message outbound-stream + (channel-stream-config maximum-packet-size + extra-request-data)) + 'subscriber) + (send-message + (channel-message outbound-stream + (channel-stream-credit initial-window-size)) + 'subscriber)))))) + +(define (handle-msg-channel-open-confirmation packet message conn) + (match-define (ssh-msg-channel-open-confirmation local-ref + remote-ref + initial-window-size + maximum-packet-size + extra-request-data*) + message) + (define ch (get-channel conn local-ref)) + (define extra-request-data (bit-string->bytes extra-request-data*)) + (define outbound-stream (channel-stream-name #f (ssh-channel-name ch))) + (transition (update-channel (ssh-channel-name ch) + (lambda (c) + (struct-copy ssh-channel c + [remote-ref remote-ref] + [outbound-packet-size maximum-packet-size])) + conn) + (send-message (channel-message outbound-stream + (channel-stream-config maximum-packet-size + extra-request-data)) + 'subscriber) + (send-message (channel-message outbound-stream + (channel-stream-credit initial-window-size)) + 'subscriber))) + +(define (handle-msg-channel-open-failure packet message conn) + (match-define (ssh-msg-channel-open-failure local-ref + reason + description* + _) + message) + (define ch (get-channel conn local-ref)) + (define description (bit-string->bytes description*)) + (define inbound-stream (channel-stream-name #t (ssh-channel-name ch))) + (prefix-transition (maybe-close-channel (ssh-channel-name ch) conn 'remote) + (send-message (channel-message inbound-stream + (channel-stream-open-failure reason description))))) + +(define (handle-msg-channel-window-adjust packet message conn) + (match-define (ssh-msg-channel-window-adjust local-ref count) message) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #f (channel-stream-credit count))) + +(define (handle-msg-channel-data packet message conn) + (match-define (ssh-msg-channel-data local-ref data*) message) + (define data (bit-string->bytes data*)) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #t (channel-stream-data data))) + +(define (handle-msg-channel-extended-data packet message conn) + (match-define (ssh-msg-channel-extended-data local-ref type-code data*) message) + (define data (bit-string->bytes data*)) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #t (channel-stream-extended-data type-code data))) + +(define (handle-msg-channel-eof packet message conn) + (define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message))) + (channel-notify conn ch #t (channel-stream-eof))) + +(define (handle-msg-channel-close packet message conn) + (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message))) + (maybe-close-channel (ssh-channel-name ch) conn 'remote)) + +(define (handle-msg-channel-request packet message conn) + (match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message) + (define type (bit-string->bytes type*)) + (define data (bit-string->bytes data*)) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #t + (if want-reply? + (channel-stream-request type data) + (channel-stream-notify type data)))) + +(define (handle-msg-channel-success packet message conn) + (match-define (ssh-msg-channel-success local-ref) message) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #f (channel-stream-ok))) + +(define (handle-msg-channel-failure packet message conn) + (match-define (ssh-msg-channel-failure local-ref) message) + (define ch (get-channel conn local-ref)) + (channel-notify conn ch #f (channel-stream-fail))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session main process @@ -537,7 +864,7 @@ 0 (rekey-in-seconds-or-bytes -1 -1 0) #f - (hash) + '() (case session-role ((client) #f) ((server) #t)) local-identification-string peer-identification-string