From 4e1d525904b3af1930e7234588b0ee67a20f5d0d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 15 Jun 2021 14:52:21 +0200 Subject: [PATCH] Push through to channel layer --- syndicate-ssh/new-server.rkt | 107 ++++----- syndicate-ssh/ssh-host-key.rkt | 3 - syndicate-ssh/ssh-session.rkt | 400 ++++++++++++++++---------------- syndicate-ssh/ssh-transport.rkt | 25 +- 4 files changed, 273 insertions(+), 262 deletions(-) diff --git a/syndicate-ssh/new-server.rkt b/syndicate-ssh/new-server.rkt index 45736ea..55a288b 100644 --- a/syndicate-ssh/new-server.rkt +++ b/syndicate-ssh/new-server.rkt @@ -25,7 +25,7 @@ (spawn-tcp-driver ds) (spawn #:name 'ssh-tcp-listener (at ds - (during/spawn (Connection $conn (TcpInbound "0.0.0.0" 29418)) + (during/spawn (Connection $conn (TcpLocal "0.0.0.0" 29418)) #:name (list 'ssh conn) (session ds conn)))))) @@ -43,66 +43,69 @@ peer-identification-string))) (define (session ground-ds conn) - (define root-facet this-facet) - - (define update-input-handler - (accept-connection conn - #:initial-credit #f - #:on-data (lambda (input mode) (error 'session "Unexpected input")))) - (define local-identification #"SSH-2.0-RacketSSH_0.0") - (send-line conn local-identification) - (send-lines-credit conn 1 (LineMode-crlf)) - (update-input-handler - #:on-data (lambda (remote-identification _mode) - (check-remote-identification! remote-identification) + (define id-line-reader-facet + (react + (on-start (send-line conn local-identification) + (send-lines-credit conn 1 (LineMode-crlf))) + (accept-connection conn + #:initial-credit #f + #:on-eof (lambda () (stop-current-facet)) + #:on-data (lambda (remote-identification _mode) + (check-remote-identification! remote-identification) + (send! session-vm-factory remote-identification))))) - (define session-vm - (actor-group [(on-stop - (stop-facet root-facet) - (log-info "Session VM for ~a closed" conn))] - (define conn-ds (dataspace #:name (gensym 'conn-ds))) + (define transfer-control + (object #:name 'transfer-control + [#:message 'transfer-control (stop-facet id-line-reader-facet)])) - (spawn/link #:name 'reader - (ssh-reader conn-ds conn update-input-handler)) - (spawn/link #:name 'writer - (ssh-writer conn-ds conn)) + (define session-vm-factory + (object + #:name 'session-vm-factory + [#:message remote-identification + (on-stop (log-info "Session VM for ~a closed" conn)) + (actor-group + #:link? #t + (define conn-ds (dataspace #:name (gensym 'conn-ds))) - ;; Wait for the reader and writer get started, then tell the reader - ;; we are ready for a single packet and spawn the session manager. - (react - (at conn-ds - (stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _)) - (send! conn-ds (inbound-credit 1)) + (spawn #:name 'reader (ssh-reader conn-ds conn transfer-control)) + (spawn #:name 'writer (ssh-writer conn-ds conn)) - (spawn/link - #:name 'session - (ssh-session conn-ds - ground-ds - local-identification - remote-identification - (lambda (user-name) - (error 'repl-boot "Would start session with ~a" user-name)) - 'server))))) + ;; Wait for the reader and writer get started, then tell the reader + ;; we are ready for a single packet and spawn the session manager. + (react + (at conn-ds + (stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _)) + (send! conn-ds (inbound-credit 1)) - (at conn-ds - ;; (during $m - ;; (on-start (log-info "++ ~v" m)) - ;; (on-stop (log-info "-- ~v" m))) - (when (message $m) - (log-info ">> ~v" m))) + (spawn + #:name 'session + (ssh-session conn-ds + ground-ds + local-identification + remote-identification + (lambda (user-name) + (error 'repl-boot "Would start session with ~a" user-name)) + 'server))))) - (at conn-ds - (when (asserted (protocol-error $reason-code $message _ $originated-at-peer?)) - (when (not originated-at-peer?) - (send! conn-ds - (outbound-packet (ssh-msg-disconnect reason-code - (string->bytes/utf-8 message) - #"")))) - (actor-system-shutdown! session-vm))))) + ;; (at conn-ds + ;; ;; (during $m + ;; ;; (on-start (log-info "++ ~v" m)) + ;; ;; (on-stop (log-info "-- ~v" m))) + ;; (when (message $m) + ;; (log-info ">> ~v" m))) - (void)))) + (at conn-ds + (when (asserted (protocol-error $reason-code $message _ $originated-at-peer?)) + (when (not originated-at-peer?) + (send! conn-ds + (outbound-packet (ssh-msg-disconnect reason-code + (string->bytes/utf-8 message) + #"")))) + (sync! conn-ds (stop-actor-system)))))])) + + (void)) ;;--------------------------------------------------------------------------- diff --git a/syndicate-ssh/ssh-host-key.rkt b/syndicate-ssh/ssh-host-key.rkt index 8b27600..ed8014b 100644 --- a/syndicate-ssh/ssh-host-key.rkt +++ b/syndicate-ssh/ssh-host-key.rkt @@ -58,9 +58,6 @@ (case host-key-alg [(ssh-ed25519) (define signature (pk-sign private-key exchange-hash)) - (log-info "signature length ~a value ~v verifies" - (bytes-length signature) - signature) (bit-string (#"ssh-ed25519" :: (t:string)) (signature :: (t:string)))])) diff --git a/syndicate-ssh/ssh-session.rkt b/syndicate-ssh/ssh-session.rkt index 4756f89..c18cc03 100644 --- a/syndicate-ssh/ssh-session.rkt +++ b/syndicate-ssh/ssh-session.rkt @@ -69,6 +69,36 @@ (struct task (seq packet-type packet message) #:prefab) (struct task-complete (seq) #:prefab) +(define-event-expander with-incoming-task + (syntax-rules () + [(_ (seq-id type-byte packet-pattern message-pattern) body ...) + (with-incoming-task* when (seq-id type-byte packet-pattern message-pattern) body ...)])) + +(define-syntax-rule + (with-incoming-task/react conn-ds (seq-id type-byte packet-pattern message-pattern) body ...) + (react + (at conn-ds + (with-incoming-task* stop-when (seq-id type-byte packet-pattern message-pattern) + body ...)))) + +(define-event-expander with-incoming-task* + (syntax-rules () + [(_ when-stx (seq-id type-byte packet-pattern message-pattern) body ...) + (when-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern)) + body ... + (send! this-target (task-complete seq-id)))])) + +(define-syntax-rule (with-assertion-presence ds assertion + #:on-present [body-present ...] + #:on-absent [body-absent ...]) + (let ((assertion-present #f)) + (at ds (when (asserted assertion) + (set! assertion-present #t) + body-present ...)) + (sync! ds (when (not assertion-present) + (void) + body-absent ...)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Key Exchange ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -120,29 +150,24 @@ (define private-key (generate-private-key group)) (match-define (list 'dh 'public p g public-key-as-integer) (pk-key->datum private-key 'rkt-public)) - (react - (at conn-ds - (when (message (task $seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e))) - (define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public)) - (define shared-secret (pk-derive-secret private-key peer-key)) - (define hash-alg sha256) - (define-values (host-key-private host-key-public) - (host-key-algorithm->keys host-key-alg)) - (define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public))) - (define exchange-hash (dh-exchange-hash hash-alg - hash-info - host-key-bytes - e - public-key-as-integer - (bit-string->integer shared-secret #t #f))) - (define h-signature (host-key-signature host-key-private host-key-alg exchange-hash)) - (log-info "h-signature ~v public-key-as-integer ~v" h-signature public-key-as-integer) - (send! conn-ds (outbound-packet - (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) - public-key-as-integer - (bit-string->bytes h-signature)))) - (send! conn-ds (task-complete seq)) - (finish shared-secret exchange-hash hash-alg))))] + (with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e)) + (define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public)) + (define shared-secret (pk-derive-secret private-key peer-key)) + (define hash-alg sha256) + (define-values (host-key-private host-key-public) (host-key-algorithm->keys host-key-alg)) + (define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public))) + (define exchange-hash (dh-exchange-hash hash-alg + hash-info + host-key-bytes + e + public-key-as-integer + (bit-string->integer shared-secret #t #f))) + (define h-signature (host-key-signature host-key-private host-key-alg exchange-hash)) + (send! conn-ds (outbound-packet + (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes) + public-key-as-integer + (bit-string->bytes h-signature)))) + (finish shared-secret exchange-hash hash-alg))] [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)])) @@ -156,23 +181,20 @@ (match-define (list 'dh 'public p g public-key-as-integer) (pk-key->datum private-key 'rkt-public)) (send! conn-ds (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) - (react - (at conn-ds - (when (message (task $seq SSH_MSG_KEXDH_REPLY _ - (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature))) - (define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public)) - (define shared-secret (pk-derive-secret private-key peer-key)) - (define hash-alg sha256) - (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes))) - (define exchange-hash (dh-exchange-hash hash-alg - hash-info - host-key-bytes - public-key-as-integer - f - (bit-string->integer shared-secret #t #f))) - (verify-host-key-signature! host-public-key host-key-alg exchange-hash h-signature) - (send! conn-ds (task-complete seq)) - (finish shared-secret exchange-hash hash-alg))))] + (with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_REPLY _ + (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)) + (define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public)) + (define shared-secret (pk-derive-secret private-key peer-key)) + (define hash-alg sha256) + (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes))) + (define exchange-hash (dh-exchange-hash hash-alg + hash-info + host-key-bytes + public-key-as-integer + f + (bit-string->integer shared-secret #t #f))) + (verify-host-key-signature! host-public-key host-key-alg exchange-hash h-signature) + (finish shared-secret exchange-hash hash-alg))] [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Bad key-exchange algorithm ~v" kex-alg)])) @@ -266,78 +288,65 @@ (extend (bytes-append key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) - (react - (at conn-ds - (when (message (task $seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys))) - ;; First, send our SSH_MSG_NEWKEYS, incrementing the - ;; various counters, and then apply the new algorithms. - ;; Also arm our rekey timer. - (rekey-state (rekey-in-seconds-or-bytes (rekey-interval) - (rekey-volume) - (total-transferred))) - (send! conn-ds 'enable-service-request!) - (send! conn-ds (outbound-packet (ssh-msg-newkeys))) - (send! conn-ds (new-keys is-server? - (embedded derive-key) - c2s-enc s2c-enc - c2s-mac s2c-mac - c2s-zip s2c-zip)) - (send! ground-ds (SetTimer 'rekey-timer - (* (rekey-wait-deadline (rekey-state)) 1000) - (TimerKind-absolute))) - (send! conn-ds (task-complete seq)))))))) + (with-incoming-task/react conn-ds (seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys)) + ;; First, send our SSH_MSG_NEWKEYS, incrementing the + ;; various counters, and then apply the new algorithms. + ;; Also arm our rekey timer. + (rekey-state (rekey-in-seconds-or-bytes (rekey-interval) + (rekey-volume) + (total-transferred))) + (send! conn-ds 'enable-service-request-handler) + (send! conn-ds (outbound-packet (ssh-msg-newkeys))) + (send! conn-ds (new-keys is-server? + (embedded derive-key) + c2s-enc s2c-enc + c2s-mac s2c-mac + c2s-zip s2c-zip)) + (send! ground-ds (SetTimer 'rekey-timer + (* (rekey-wait-deadline (rekey-state)) 1000) + (TimerKind-absolute))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Service request manager +;; Service request manager and user authentication ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (define (handle-msg-service-request packet message conn) -;; (define service (bit-string->bytes (ssh-msg-service-request-service-name message))) -;; (match service -;; [#"ssh-userauth" -;; (if (connection-authentication-state conn) -;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE -;; "Repeated authentication is not permitted") -;; (sequence-actions (transition conn) -;; (send-message (outbound-packet (ssh-msg-service-accept service))) -;; (lambda (conn) (transition -;; (oneshot-handler conn -;; SSH_MSG_USERAUTH_REQUEST -;; handle-msg-userauth-request)))))] -;; [else -;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE -;; "Service ~v not supported" -;; service)])) +(define (service-request-handler conn-ds) + (define-field authentication-state #f) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; User authentication -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (at conn-ds + (assert #:when (authentication-state) (authentication-state)) -;; (define (handle-msg-userauth-request packet message conn) -;; (define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message))) -;; (define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message))) -;; (cond -;; [(and (positive? (bytes-length user-name)) -;; (equal? service-name #"ssh-connection")) -;; ;; TODO: Actually implement client authentication -;; (sequence-actions (transition conn) -;; (send-message (outbound-packet (ssh-msg-userauth-success))) -;; (lambda (conn) -;; (start-connection-service -;; (set-handlers (struct-copy connection conn -;; [authentication-state (authenticated user-name service-name)]) -;; SSH_MSG_USERAUTH_REQUEST -;; (lambda (packet message conn) -;; ;; RFC4252 section 5.1 page 6 -;; conn)))) -;; (lambda (conn) -;; (transition conn -;; ;; TODO: canary for NESTED VM!: #:exit-signal? #t -;; (spawn-vm #:debug-name 'ssh-application-vm -;; ((connection-application-boot conn) user-name)))))] -;; [else -;; (transition conn -;; (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))])) + (with-incoming-task (seq SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service)) + (match service + [#"ssh-userauth" + (cond + [(authentication-state) + (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE + "Repeated authentication is not permitted")] + [else + (send! conn-ds (outbound-packet (ssh-msg-service-accept service))) + (with-incoming-task/react conn-ds + (seq SSH_MSG_USERAUTH_REQUEST _ + (ssh-msg-userauth-request $user-name $service-name _ _)) + (cond + [(and (positive? (bytes-length user-name)) + (equal? service-name #"ssh-connection")) + ;; TODO: Actually implement client authentication + (send! conn-ds (outbound-packet (ssh-msg-userauth-success))) + (authentication-state (authenticated user-name service-name)) + (react + (at conn-ds + (with-incoming-task (seq SSH_MSG_USERAUTH_REQUEST _ _) + ;; RFC4252 section 5.1 page 6 + ))) + (let ((a (authentication-state))) + (spawn #:name 'connection-service (start-connection-service conn-ds a)))] + [else + (send! conn-ds (outbound-packet (ssh-msg-userauth-failure '(none) #f)))]))])] + [_ + (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE + "Service ~v not supported" + service)])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Channel management @@ -518,65 +527,78 @@ ;; '()))) ;; (transition conn))) -;; (define (start-connection-service conn) -;; (sequence-actions -;; (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. -;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) -;; (match-state conn -;; (match-conversation (channel-message (channel-stream-name #t cname) _) -;; (on-presence (respond-to-opened-outbound-channel conn cname))))) -;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) -;; (match-state conn -;; (match-conversation (channel-message (channel-stream-name #f cname) _) -;; (on-presence (respond-to-opened-outbound-channel conn cname))))))) +(define (start-connection-service conn-ds authentication) + (match-define (authenticated user-name _service-name) authentication) -;; (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) + (handle-msg-channel-open conn-ds) -;; (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)) + ;; (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)) -;; (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)) + ;; (at conn-ds + ;; (during ...)) + ;; ;; 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. + ;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) + ;; (match-state conn + ;; (match-conversation (channel-message (channel-stream-name #t cname) _) + ;; (on-presence (respond-to-opened-outbound-channel conn cname))))) + ;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?) + ;; (match-state conn + ;; (match-conversation (channel-message (channel-stream-name #f cname) _) + ;; (on-presence (respond-to-opened-outbound-channel conn cname))))) + (void) + ) -;; (transition (update-channel cname -;; (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref])) -;; conn) -;; (channel-endpoints cname -;; (lambda (inbound-stream outbound-stream) -;; (list (send-feedback -;; (channel-message outbound-stream -;; (channel-stream-config maximum-packet-size -;; extra-request-data))) -;; (send-feedback -;; (channel-message outbound-stream -;; (channel-stream-credit initial-window-size)))))))) +(define (handle-msg-channel-open conn-ds) + (void) + ;; (at conn-ds + ;; (with-incoming-task (seq SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type + ;; $remote-ref + ;; $initial-window-size + ;; $maximum-packet-size + ;; $extra-request-data)) + ;; (react + ;; (at conn-ds + ;; (when (asserted (Observe (:pattern ( + ;; (sync! conn-ds + ;; ( + ;; (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-endpoints cname + ;; (lambda (inbound-stream outbound-stream) + ;; (list (send-feedback + ;; (channel-message outbound-stream + ;; (channel-stream-config maximum-packet-size + ;; extra-request-data))) + ;; (send-feedback + ;; (channel-message outbound-stream + ;; (channel-stream-credit initial-window-size)))))))) + ) ;; (define (handle-msg-channel-open-confirmation packet message conn) ;; (match-define (ssh-msg-channel-open-confirmation local-ref @@ -674,59 +696,48 @@ (define-field total-transferred 0) (define-field discard-next-packet? #f) - (define authentication-state #f) (define channels '()) - (define is-server? (case session-role ((client) #f) ((server) #t))) (at conn-ds - (when (message (task $seq SSH_MSG_DISCONNECT _ - (ssh-msg-disconnect $reason-code $description $language-tag))) + (with-incoming-task (seq SSH_MSG_DISCONNECT _ + (ssh-msg-disconnect $reason-code $description $language-tag)) (disconnect-with-error* conn-ds #t '() reason-code "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" reason-code - (bytes->string/utf-8 (bit-string->bytes description))) - (send! conn-ds (task-complete seq))) + (bytes->string/utf-8 (bit-string->bytes description)))) - (when (message (task $seq SSH_MSG_IGNORE _ (ssh-msg-ignore _))) - (send! conn-ds (task-complete seq))) + (with-incoming-task (seq SSH_MSG_IGNORE _ (ssh-msg-ignore _))) - (when (message (task $seq SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq))) + (with-incoming-task (seq SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq)) (disconnect-with-error/local-info conn-ds `((offending-sequence-number ,peer-seq)) SSH_DISCONNECT_PROTOCOL_ERROR - "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.") - (send! conn-ds (task-complete seq))) + "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")) - (when (message (task $seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _)))) - (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)) - (send! conn-ds (task-complete seq))) + (with-incoming-task (seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _))) + (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))) - (when (message (task $seq SSH_MSG_KEXINIT $packet - ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _)))) + (with-incoming-task (seq SSH_MSG_KEXINIT $packet + ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))) (do-kexinit conn-ds ground-ds #:packet packet #:message message #:rekey-state rekey-state - #:is-server? is-server? + #:is-server? (case session-role ((client) #f) ((server) #t)) #:local-id local-identification-string #:remote-id peer-identification-string #:session-id session-id #:total-transferred total-transferred - #:discard-next-packet? discard-next-packet?) - (send! conn-ds (task-complete seq))) + #:discard-next-packet? discard-next-packet?))) - (when (message 'enable-service-request!) - (log-info "Saw enable-service-request!") - ;; TODO:: - ;; (set-handlers - ;; (struct-copy connection conn [rekey-state new-rekey-state]) - ;; SSH_MSG_SERVICE_REQUEST handle-msg-service-request) - ) - ) + (react + (at conn-ds + (stop-when (message 'enable-service-request-handler) + (spawn #:name 'service-request-handler (service-request-handler conn-ds))))) (define (maybe-rekey) (match (rekey-state) @@ -768,14 +779,11 @@ (react (on-start (send! conn-ds (task sequence-number packet-type-number payload message))) - (let ((handler-present #f)) - (at conn-ds - (when (asserted (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _)) - (set! handler-present #t))) - (sync! conn-ds - (when (not handler-present) - (send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number))) - (send! conn-ds (task-complete sequence-number))))) + (with-assertion-presence conn-ds + (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _) + #:on-present [] + #:on-absent [(send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number))) + (send! conn-ds (task-complete sequence-number))]) (at conn-ds (stop-when (message (task-complete sequence-number)))) (on-stop (send! conn-ds (inbound-credit 1))))))) (total-transferred (+ (total-transferred) transfer-size)) diff --git a/syndicate-ssh/ssh-transport.rkt b/syndicate-ssh/ssh-transport.rkt index b805741..8c9d37b 100644 --- a/syndicate-ssh/ssh-transport.rkt +++ b/syndicate-ssh/ssh-transport.rkt @@ -258,7 +258,14 @@ ;; Encrypted Packet Input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (ssh-reader conn-ds conn update-input-handler) +(define (ssh-reader conn-ds conn transfer-control) + (define input-handler #f) + (define (update-input-handler #:on-data proc) (set! input-handler proc)) + (assert-control conn + #:on-eof (lambda () (stop-current-facet)) + #:on-data (lambda (data mode) (input-handler data mode))) + (send! transfer-control 'transfer-control) + (define packet-size-limit (default-packet-limit)) (define sequence-number 0) (define remaining-credit 0) @@ -274,7 +281,7 @@ (define (issue-credit) (when (positive? remaining-credit) - (send-bytes-credit conn (block-size)))) + (send-packet-credit conn (block-size)))) (define (handle-packet-header encrypted-packet _mode) (define first-block (decrypt-chunk encrypted-packet)) @@ -284,11 +291,11 @@ (define remaining-to-read (- packet-length amount-of-packet-in-first-block)) (if (positive? remaining-to-read) (begin - (send-bytes-credit conn remaining-to-read) + (send-packet-credit conn remaining-to-read) (update-input-handler #:on-data (lambda (encrypted-packet _mode) - (check-hmac (bytes-append first-block (decrypt-chunk encrypted-packet)) - packet-length)))) + (define subsequent-chunk (decrypt-chunk encrypted-packet)) + (check-hmac (bytes-append first-block subsequent-chunk) packet-length)))) (check-hmac first-block packet-length))) (define (check-hmac packet packet-length) @@ -298,7 +305,7 @@ (define mac-byte-count (bytes-length computed-hmac-bytes)) (if (positive? mac-byte-count) (begin - (send-bytes-credit conn mac-byte-count) + (send-packet-credit conn mac-byte-count) (update-input-handler #:on-data (lambda (received-hmac-bytes _mode) (if (equal? computed-hmac-bytes received-hmac-bytes) @@ -322,9 +329,7 @@ (set! remaining-credit (- remaining-credit 1)) (issue-credit)) - (update-input-handler - #:on-eof (lambda () (stop-current-facet)) - #:on-data handle-packet-header) + (update-input-handler #:on-data handle-packet-header) (at conn-ds (when (message (inbound-credit $amount)) @@ -338,8 +343,6 @@ ;; Encrypted Packet Output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (struct ssh-writer-state (config sequence-number) #:prefab) - (define (ssh-writer conn-ds conn) (define config initial-crypto-configuration) (define sequence-number 0)