forked from syndicate-lang/marketplace-ssh-2014
791 lines
36 KiB
Racket
791 lines
36 KiB
Racket
#lang syndicate
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(require bitsyntax)
|
|
(require syndicate/drivers/timer)
|
|
|
|
(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")
|
|
|
|
(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 (authenticated String String), 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.
|
|
(struct authenticated (username service) #:prefab)
|
|
|
|
;; 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-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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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))
|
|
(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)]))
|
|
|
|
;; 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))
|
|
(send! conn-ds (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
|
|
(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)]))
|
|
|
|
(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))))))))))
|
|
(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 and user authentication
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (service-request-handler conn-ds)
|
|
(define-field authentication-state #f)
|
|
|
|
(at conn-ds
|
|
(assert #:when (authentication-state) (authentication-state))
|
|
|
|
(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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; (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<Uint32> 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-endpoint (list cname 'outbound))
|
|
;; (delete-endpoint (list cname 'inbound)))]
|
|
;; [else (list)])])))]
|
|
;; [else (transition conn)]))
|
|
|
|
;; (define (channel-endpoints 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
|
|
;; (name-endpoint (list cname 'outbound)
|
|
;; (subscriber (channel-message outbound-stream-name (wild))
|
|
;; (match-state conn
|
|
;; (on-presence (transition conn
|
|
;; (initial-message-producer inbound-stream-name outbound-stream-name)))
|
|
;; (on-absence (maybe-close-channel cname conn 'local))
|
|
;; (on-message
|
|
;; [(channel-message _ body)
|
|
;; (let ()
|
|
;; (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 #""))]))]))))
|
|
;; (name-endpoint (list cname 'inbound)
|
|
;; (publisher (channel-message inbound-stream-name (wild))
|
|
;; (match-state conn
|
|
;; (on-message
|
|
;; [(channel-message _ body)
|
|
;; (let ()
|
|
;; (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
|
|
;; maximum-packet-size
|
|
;; 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
|
|
;; maximum-packet-size
|
|
;; 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 (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-ds authentication)
|
|
(match-define (authenticated user-name _service-name) authentication)
|
|
|
|
(handle-msg-channel-open conn-ds)
|
|
|
|
;; (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))
|
|
|
|
;; (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)
|
|
)
|
|
|
|
(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
|
|
;; 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))))
|
|
|
|
;; (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
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (ssh-session conn-ds
|
|
ground-ds
|
|
local-identification-string
|
|
peer-identification-string
|
|
application-boot
|
|
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 (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))))
|
|
|
|
(with-incoming-task (seq SSH_MSG_IGNORE _ (ssh-msg-ignore _)))
|
|
|
|
(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."))
|
|
|
|
(with-incoming-task (seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _)))
|
|
(log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)))
|
|
|
|
(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? (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-when (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
|
|
(when (message (TimerExpired 'rekey-timer _))
|
|
(maybe-rekey)))
|
|
|
|
(at conn-ds
|
|
(when (message (outbound-byte-credit $amount))
|
|
(total-transferred (+ (total-transferred) amount))
|
|
(maybe-rekey))
|
|
|
|
(when (message (inbound-packet $sequence-number $payload $message $transfer-size))
|
|
(if (discard-next-packet?)
|
|
(begin (discard-next-packet? #f)
|
|
(send! conn-ds (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! conn-ds (task sequence-number packet-type-number payload message)))
|
|
(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))
|
|
(maybe-rekey))))
|