#lang syndicate ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones (require bitsyntax) (require syndicate/drivers/timer) (require syndicate/drivers/stream) (require syndicate/pattern) (require "crypto.rkt") (require "oakley-groups.rkt") (require "ssh-host-key.rkt") (require "ssh-numbers.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") (require "ssh-transport.rkt") (require "ssh-channel.rkt") (require "schemas/gen/channel.rkt") (require "schemas/gen/auth.rkt") (provide rekey-interval rekey-volume ssh-session) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; A RekeyState is one of ;; - a (rekey-wait Number Number), representing a time or ;; transfer-amount by which rekeying should be started ;; - a (rekey-local SshMsgKexinit), when we've sent our local ;; algorithm list and are waiting for the other party to send theirs ;; - a (rekey-in-progress KeyExchangeState), when both our local ;; algorithm list has been sent and the remote one has arrived and the ;; actual key exchange has begun (struct rekey-wait (deadline threshold-bytes) #:transparent) (struct rekey-local (local-algorithms) #:transparent) (struct rekey-in-progress (state) #:transparent) ;; An AuthenticationState is one of ;; - #f, for not-yet-authenticated ;; - an (SshAuthenticatedUser Bytes Bytes), recording successful completion ;; of the authentication protocol after a request to be identified ;; as the given username for the given service. ;; TODO: When authentication is properly implemented, we will need ;; intermediate states here too. ;; Generic inputs into the exchange-hash part of key ;; exchange. Diffie-Hellman uses these fields along with the host key, ;; the exchange values, and the shared secret to get the final hash. (struct exchange-hash-info (client-id server-id client-kexinit-bytes server-kexinit-bytes) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parameters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define rekey-interval (make-parameter 3600)) (define rekey-volume (make-parameter 1000000000)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Packet dispatch and handling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; (task Nat Byte Bytes SshMsg) ;; (task-complete Nat) ;; Message handlers respond to `task` messages, eventually sending `task-complete`. (struct task (seq packet-type packet message) #:prefab) (struct task-complete (seq) #:prefab) (define-syntax with-incoming-task (syntax-rules () [(_ (type-byte packet-pattern message-pattern) body ...) (with-incoming-task* on (type-byte packet-pattern message-pattern) body ...)])) (define-syntax-rule (with-incoming-task/react (type-byte packet-pattern message-pattern) body ...) (react (with-incoming-task* stop-on (type-byte packet-pattern message-pattern) body ...))) (define-syntax with-incoming-task* (syntax-rules () [(_ on-stx (type-byte packet-pattern message-pattern) body ...) (on-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern)) body ... (send! (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 (on (asserted assertion) (set! assertion-present #t) body-present ...)) (sync! ds (when (not assertion-present) (void) body-absent ...)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Key Exchange ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred) (rekey-wait (+ (current-seconds) delta-seconds) (+ total-transferred delta-bytes))) ;; DS (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol ;; Computes the name of the "best" algorithm choice at the given ;; getter, using the rules from the RFC and the client and server ;; algorithm precedence lists. (define (best-result conn-ds getter client-algs server-algs) (define client-list0 (getter client-algs)) (define server-list (getter server-algs)) (let loop ((client-list client-list0)) (cond ((null? client-list) (disconnect-with-error/local-info conn-ds `((client-list ,client-list0) (server-list ,server-list)) SSH_DISCONNECT_KEY_EXCHANGE_FAILED "Could not agree on a suitable algorithm for ~v" getter)) ((memq (car client-list) server-list) (car client-list)) (else (loop (cdr client-list)))))) ;; HashFunction ExchangeHashInfo Bytes Natural Natural Natural -> Bytes ;; Computes the session ID as defined by SSH's DH key exchange method. (define (dh-exchange-hash hash-alg hash-info host-key e f k) (let ((block-to-hash (bit-string->bytes (bit-string ((exchange-hash-info-client-id hash-info) :: (t:string)) ((exchange-hash-info-server-id hash-info) :: (t:string)) ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string)) ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string)) (host-key :: (t:string)) (e :: (t:mpint)) (f :: (t:mpint)) (k :: (t:mpint)))))) (hash-alg block-to-hash))) ;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void ;; Performs the server's half of the Diffie-Hellman key exchange protocol. (define (perform-server-key-exchange conn-ds hash-info kex-alg host-key-alg finish) (match kex-alg ['diffie-hellman-group14-sha256 (define group dh:oakley-group-14) (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)) (at conn-ds (with-incoming-task/react (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! (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)])) ;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void ;; Performs the client's half of the Diffie-Hellman key exchange protocol. (define (perform-client-key-exchange conn-ds hash-info kex-alg host-key-alg finish) (match kex-alg ['diffie-hellman-group14-sha256 (define group dh:oakley-group-14) (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)) (at conn-ds (send! (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) (with-incoming-task/react (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)])) (define (do-kexinit conn-ds ground-ds #:packet packet #:message message #:rekey-state rekey-state #:is-server? is-server? #:local-id local-id #:remote-id remote-id #:session-id session-id #:total-transferred total-transferred #:discard-next-packet? discard-next-packet?) (define local-algs (match (rekey-state) [(? rekey-wait?) ((local-algorithm-list))] [(rekey-local local-algs) local-algs] [(? rekey-in-progress?) (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR "Received SSH_MSG_KEXINIT during ongoing key exchange")])) (define encoded-local-algs (ssh-message-encode local-algs)) (define remote-algs message) (define encoded-remote-algs packet) (define c (if is-server? remote-algs local-algs)) (define s (if is-server? local-algs remote-algs)) (define kex-alg (best-result conn-ds ssh-msg-kexinit-kex_algorithms c s)) (define host-key-alg (best-result conn-ds ssh-msg-kexinit-server_host_key_algorithms c s)) (define c2s-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_client_to_server c s)) (define s2c-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_server_to_client c s)) (define c2s-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_client_to_server c s)) (define s2c-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_server_to_client c s)) (define c2s-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_client_to_server c s)) (define s2c-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_server_to_client c s)) ;; Ignore languages. ;; Don't check the reserved field here, either. TODO: should we? (define (guess-matches? chosen-value getter) (let ((remote-choices (getter remote-algs))) (and (pair? remote-choices) ;; not strictly necessary because of ;; the error behaviour of ;; best-result. (eq? (car remote-choices) ;; the remote peer's guess for this parameter chosen-value)))) (define should-discard-first-kex-packet (and (ssh-msg-kexinit-first_kex_packet_follows remote-algs) ;; They've already transmitted their guess. Does their guess match ;; what we've actually selected? (not (and (guess-matches? kex-alg ssh-msg-kexinit-kex_algorithms) (guess-matches? host-key-alg ssh-msg-kexinit-server_host_key_algorithms) (guess-matches? c2s-enc ssh-msg-kexinit-encryption_algorithms_client_to_server) (guess-matches? s2c-enc ssh-msg-kexinit-encryption_algorithms_server_to_client) (guess-matches? c2s-mac ssh-msg-kexinit-mac_algorithms_client_to_server) (guess-matches? s2c-mac ssh-msg-kexinit-mac_algorithms_server_to_client) (guess-matches? c2s-zip ssh-msg-kexinit-compression_algorithms_client_to_server) (guess-matches? s2c-zip ssh-msg-kexinit-compression_algorithms_server_to_client))))) (when should-discard-first-kex-packet (discard-next-packet? #t)) (when (rekey-wait? (rekey-state)) (rekey-state (rekey-local local-algs)) (send! conn-ds (outbound-packet local-algs))) ((if is-server? perform-server-key-exchange perform-client-key-exchange) conn-ds (if is-server? (exchange-hash-info remote-id local-id encoded-remote-algs encoded-local-algs) (exchange-hash-info local-id remote-id encoded-local-algs encoded-remote-algs)) kex-alg host-key-alg (lambda (shared-secret exchange-hash hash-alg) (when (not (session-id)) (session-id exchange-hash)) ;; don't overwrite existing ID (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint)) (exchange-hash :: binary))) (define (derive-key kind needed-bytes-or-false) (let extend ((key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (kind :: binary) ((session-id) :: binary)))))) (cond ((eq? #f needed-bytes-or-false) key) ((>= (bytes-length key) needed-bytes-or-false) (subbytes key 0 needed-bytes-or-false)) (else (extend (bytes-append key (hash-alg (bit-string->bytes (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) (at conn-ds (with-incoming-task/react (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! 'enable-service-request-handler) (send! (outbound-packet (ssh-msg-newkeys))) (send! (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 and user authentication ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (service-request-handler conn-ds) (define-field authentication-state #f) (begin/dataflow (log-info "authentication-state ~s" (authentication-state))) (at conn-ds (assert #:when (authentication-state) (authentication-state)) (with-incoming-task (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 (at conn-ds (send! (outbound-packet (ssh-msg-service-accept service))) (with-incoming-task/react (SSH_MSG_USERAUTH_REQUEST _ (ssh-msg-userauth-request $user-name $service-name $method-name $extension)) (log-info "SSH-MSG-USERAUTH-REQUEST ~s ~s ~s ~s" user-name service-name method-name extension) (send! (outbound-packet (ssh-msg-userauth-banner #"Welcome to Racket SSH!\r\n" #""))) (cond [(and (positive? (bytes-length user-name)) (equal? service-name #"ssh-connection")) ;; TODO: Actually implement client authentication (send! (outbound-packet (ssh-msg-userauth-success))) (authentication-state (SshAuthenticatedUser user-name service-name)) (react (with-incoming-task (SSH_MSG_USERAUTH_REQUEST _ _) ;; RFC4252 section 5.1 page 6 )) (spawn #:name 'channel-manager (run-channel-manager conn-ds))] [else (send! (outbound-packet (ssh-msg-userauth-failure '(none) #f)))])))])] [_ (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE "Service ~v not supported" service)])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Channel management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (run-inbound-channel conn-ds #:type channel-type #:remote-ref remote-ref #:local-ref local-ref #:initial-window-size initial-window-size #:maximum-packet-size maximum-packet-size #:extra-request-data extra-request-data) (define (! message) (send! conn-ds (outbound-packet message))) (log-info "Starting channel, type ~s" channel-type) (on-stop (log-info "Stopping channel, type ~s" channel-type)) (define (on-connect source sink) (at conn-ds (stop-on (message (task _ SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close local-ref)))) (with-incoming-task (SSH_MSG_CHANNEL_WINDOW_ADJUST _ (ssh-msg-channel-window-adjust local-ref $n)) (send-bytes-credit source n)) (with-incoming-task (SSH_MSG_CHANNEL_DATA _ (ssh-msg-channel-data local-ref $data)) (send-data sink data)) (with-incoming-task (SSH_MSG_CHANNEL_EXTENDED_DATA _ (ssh-msg-channel-extended-data local-ref $type-code $data)) (send-data sink data (Mode-object (SshChannelObject-extended-data type-code)))) (with-incoming-task (SSH_MSG_CHANNEL_EOF _ (ssh-msg-channel-eof local-ref)) (send-eof sink)) (with-incoming-task (SSH_MSG_CHANNEL_REQUEST _ (ssh-msg-channel-request local-ref $type $want-reply? $data)) (send-data sink data (Mode-object (SshChannelObject-request type want-reply?)))) (with-incoming-task (SSH_MSG_CHANNEL_SUCCESS _ (ssh-msg-channel-success local-ref)) (send-data sink #"" (Mode-object (SshChannelObject-success)))) (with-incoming-task (SSH_MSG_CHANNEL_FAILURE _ (ssh-msg-channel-failure local-ref)) (send-data sink #"" (Mode-object (SshChannelObject-failure)))) (once [(asserted (SshChannelOpenResponse-ok remote-sink $extra-data)) (! (ssh-msg-channel-open-confirmation remote-ref local-ref 1048576 ;; TODO 16384 ;; TODO extra-data))] [(asserted (SshChannelOpenResponse-fail remote-sink $reason $description)) (! (ssh-msg-channel-open-failure remote-ref reason description #"")) (stop-current-facet)]))) (match-define (list remote-source remote-sink) (establish-connection conn-ds (SshChannelLocal channel-type extra-request-data) #:name (list 'R remote-ref 'L local-ref) #:on-connect on-connect #:on-rejected (lambda (message) (! (ssh-msg-channel-open-failure remote-ref SSH_OPEN_ADMINISTRATIVELY_PROHIBITED (string->bytes/utf-8 message) #"")) (stop-current-facet)) #:on-disconnect (lambda () (stop-current-facet)) #:on-error (lambda (message) (stop-current-facet)) #:on-credit (lambda (amount mode) (match-define (Mode-bytes) mode) (match-define (CreditAmount-count n) amount) (! (ssh-msg-channel-window-adjust remote-ref n))) #:initial-credit (CreditAmount-count initial-window-size) #:initial-mode (Mode-bytes) #:on-data (lambda (data mode) (match mode [(Mode-bytes) (! (ssh-msg-channel-data remote-ref data))] [(Mode-lines (LineMode-lf)) (! (ssh-msg-channel-data remote-ref (bytes-append data "\n")))] [(Mode-lines (LineMode-crlf)) (! (ssh-msg-channel-data remote-ref (bytes-append data "\r\n")))] [(Mode-object (:parse (SshChannelObject-extended-data type-code))) (! (ssh-msg-channel-extended-data remote-ref type-code data))] [(Mode-object (:parse (SshChannelObject-request type want-reply))) (! (ssh-msg-channel-request remote-ref type want-reply data))] [(Mode-object (:parse (SshChannelObject-success))) (! (ssh-msg-channel-success remote-ref))] [(Mode-object (:parse (SshChannelObject-failure))) (! (ssh-msg-channel-failure remote-ref))])) #:on-eof (lambda () (! (ssh-msg-channel-eof remote-ref))))) (void)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Channel manager ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (run-channel-manager conn-ds) (define local-refs-by-remote-ref (make-hash)) (define remote-refs-by-local-ref (make-hash)) (define (allocate-local-ref remote-ref) (when (hash-has-key? local-refs-by-remote-ref remote-ref) (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR "Attempt to reuse remote-ref ~a" remote-ref)) (for/or ([i (in-range 0 32)]) ;; TODO: this is an arbitrary limit (if (hash-has-key? remote-refs-by-local-ref i) #f (begin (hash-set! remote-refs-by-local-ref i remote-ref) (hash-set! local-refs-by-remote-ref remote-ref i) i)))) (at conn-ds (with-incoming-task (SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close $local-ref)) (when (not (hash-has-key? remote-refs-by-local-ref local-ref)) (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR "Received channel close for non-open channel ~a" local-ref)) (hash-remove! remote-refs-by-local-ref local-ref)) (with-incoming-task (SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type $remote-ref $initial-window-size $maximum-packet-size $extra-request-data)) (log-info "open ~s" (list channel-type remote-ref initial-window-size maximum-packet-size extra-request-data)) (with-assertion-presence conn-ds (SshChannelTypeAvailable channel-type) #:on-present [(define local-ref (allocate-local-ref remote-ref)) (if (not local-ref) (send! (outbound-packet (ssh-msg-channel-open-failure remote-ref SSH_OPEN_RESOURCE_SHORTAGE #"Too many open channels" #""))) (react (on-stop (log-info "Releasing channel assignment ~s" (list 'R remote-ref 'L local-ref)) (send! (outbound-packet (ssh-msg-channel-close remote-ref))) (hash-remove! local-refs-by-remote-ref remote-ref)) (spawn/link #:name (list 'R remote-ref 'L local-ref) (run-inbound-channel conn-ds #:type channel-type #:remote-ref remote-ref #:local-ref local-ref #:initial-window-size initial-window-size #:maximum-packet-size maximum-packet-size #:extra-request-data extra-request-data))))] #:on-absent [(send! (outbound-packet (ssh-msg-channel-open-failure remote-ref SSH_OPEN_UNKNOWN_CHANNEL_TYPE #"Unknown channel type" #"")))]))) ;; 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 (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-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-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))) ;; (sequence-actions (transition conn) ;; (send-message (channel-message inbound-stream ;; (channel-stream-open-failure reason description))) ;; (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session main process ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (ssh-session conn-ds ground-ds local-identification-string peer-identification-string session-role) (define-field rekey-state (rekey-in-seconds-or-bytes -1 -1 0)) (define-field session-id #f) (define-field total-transferred 0) (define-field discard-next-packet? #f) (define channels '()) (at conn-ds (with-incoming-task (SSH_MSG_DISCONNECT _ (ssh-msg-disconnect $reason-code $description $language-tag)) (if (= reason-code SSH_DISCONNECT_BY_APPLICATION) (begin (log-debug "Received SSH_DISCONNECT_BY_APPLICATION") (assert (protocol-error reason-code description '() #t))) (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))))) (with-incoming-task (SSH_MSG_IGNORE _ (ssh-msg-ignore _))) (with-incoming-task (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.")) (with-incoming-task (SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _))) (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))) (with-incoming-task (SSH_MSG_KEXINIT $packet ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))) (do-kexinit conn-ds ground-ds #:packet packet #:message message #:rekey-state rekey-state #: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?))) (react (at conn-ds (stop-on (message 'enable-service-request-handler) (spawn #:name 'service-request-handler (service-request-handler conn-ds))))) (define (maybe-rekey) (match (rekey-state) [(rekey-wait deadline threshold-bytes) (when (or (>= (current-seconds) deadline) (>= (total-transferred) threshold-bytes)) (define algs ((local-algorithm-list))) (send! conn-ds (outbound-packet algs)) (rekey-state (rekey-local algs)))] [_ (void)])) (at ground-ds (on (message (TimerExpired 'rekey-timer _)) (maybe-rekey))) (at conn-ds (on (message (outbound-byte-credit $amount)) (total-transferred (+ (total-transferred) amount)) (maybe-rekey)) (on (message (inbound-packet $sequence-number $payload $message $transfer-size)) (if (discard-next-packet?) (begin (discard-next-packet? #f) (send! (inbound-credit 1))) (let ((packet-type-number (bytes-ref payload 0))) (if (and (not (rekey-wait? (rekey-state))) (or (not (ssh-msg-type-transport-layer? packet-type-number)) (= packet-type-number SSH_MSG_SERVICE_REQUEST) (= packet-type-number SSH_MSG_SERVICE_ACCEPT))) ;; We're in the middle of some phase of an active key-exchange, ;; and received a packet that's for a higher layer than the ;; transport layer, or one of the forbidden types given at the ;; send of RFC4253 section 7.1. (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR "Packets of type ~v forbidden while in key-exchange" packet-type-number) ;; We're either idling, or it's a permitted packet type while ;; performing key exchange. Dispatch it. (react (on-start (send! (task sequence-number packet-type-number payload message))) (with-assertion-presence conn-ds (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _) #:on-present [] #:on-absent [(send! (outbound-packet (ssh-msg-unimplemented sequence-number))) (send! (task-complete sequence-number))]) (stop-on (message (task-complete sequence-number))) (on-stop (send! (inbound-credit 1))))))) (total-transferred (+ (total-transferred) transfer-size)) (maybe-rekey))))