OS2-ized SSH up to channel management
This commit is contained in:
parent
72acd94def
commit
78a0721051
|
@ -6,18 +6,31 @@
|
||||||
|
|
||||||
(require "ssh-numbers.rkt")
|
(require "ssh-numbers.rkt")
|
||||||
(require "ssh-transport.rkt")
|
(require "ssh-transport.rkt")
|
||||||
|
(require "ssh-session.rkt")
|
||||||
(require "ssh-message-types.rkt")
|
(require "ssh-message-types.rkt")
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
(require "os2-support.rkt")
|
(require "os2-support.rkt")
|
||||||
|
|
||||||
(define server-addr (tcp-listener 2322))
|
(define server-addr (tcp-listener 2322))
|
||||||
|
|
||||||
|
(define (check-remote-identification! peer-identification-string)
|
||||||
|
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
|
||||||
|
;; Each identification string is both a cleartext indicator that
|
||||||
|
;; we've reached some notion of the right place and also input to
|
||||||
|
;; the hash function used during D-H key exchange.
|
||||||
|
(when (not (regexp-match required-peer-identification-regex
|
||||||
|
peer-identification-string))
|
||||||
|
(error 'ssh-session
|
||||||
|
"Invalid peer identification string ~v"
|
||||||
|
peer-identification-string)))
|
||||||
|
|
||||||
(define (connection-handler local-addr remote-addr)
|
(define (connection-handler local-addr remote-addr)
|
||||||
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
||||||
(nested-vm
|
(nested-vm
|
||||||
(list 'ssh-session-vm remote-addr)
|
(list 'ssh-session-vm remote-addr)
|
||||||
(lambda (nested-boot-pid)
|
(lambda (nested-boot-pid)
|
||||||
(transition 'running
|
(transition 'running
|
||||||
|
(spawn (timer-relay 'ssh-timer-relay) #:debug-name 'ssh-timer-relay)
|
||||||
|
|
||||||
;; Issue identification string.
|
;; Issue identification string.
|
||||||
(at-meta-level
|
(at-meta-level
|
||||||
|
@ -39,6 +52,7 @@
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
[(tcp-channel _ _ (? eof-object?))
|
||||||
(transition state (kill))]
|
(transition state (kill))]
|
||||||
[(tcp-channel _ _ (? bytes? remote-identification))
|
[(tcp-channel _ _ (? bytes? remote-identification))
|
||||||
|
(check-remote-identification! remote-identification)
|
||||||
;; First, set the incoming mode to bytes. Then
|
;; First, set the incoming mode to bytes. Then
|
||||||
;; initialise the reader, switching to packet-reading
|
;; initialise the reader, switching to packet-reading
|
||||||
;; mode. Finally, spawn the remaining processes and
|
;; mode. Finally, spawn the remaining processes and
|
||||||
|
@ -49,9 +63,14 @@
|
||||||
(spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
(spawn (ssh-writer local-addr remote-addr) #:debug-name 'ssh-writer)
|
||||||
;; Wait for a cycle to let the reader and writer get
|
;; Wait for a cycle to let the reader and writer get
|
||||||
;; started, then tell the reader we are ready for a
|
;; started, then tell the reader we are ready for a
|
||||||
;; single packet.
|
;; single packet and spawn the session manager.
|
||||||
(yield #:state state
|
(yield #:state state
|
||||||
(transition state (send-message (inbound-credit 1)))))])))
|
(transition state
|
||||||
|
(send-message (inbound-credit 1))
|
||||||
|
(spawn (ssh-session local-identification
|
||||||
|
remote-identification
|
||||||
|
'server)
|
||||||
|
#:debug-name 'ssh-session))))])))
|
||||||
#:debug-name 'ssh-reader)
|
#:debug-name 'ssh-reader)
|
||||||
|
|
||||||
(role 'crash-listener
|
(role 'crash-listener
|
||||||
|
|
|
@ -88,8 +88,13 @@
|
||||||
([ (bs :: binary bytes n) (rest :: binary) ]
|
([ (bs :: binary bytes n) (rest :: binary) ]
|
||||||
(ks (bit-string->bytes bs) rest))
|
(ks (bit-string->bytes bs) rest))
|
||||||
(else (kf)))))
|
(else (kf)))))
|
||||||
((_ #f n) (lambda (bs)
|
((_ #t) (lambda (input ks kf)
|
||||||
(bit-string (bs :: binary))))))
|
(bit-string-case input
|
||||||
|
([ (rest :: binary) ]
|
||||||
|
(ks (bit-string->bytes rest) #""))
|
||||||
|
(else (kf)))))
|
||||||
|
((_ #f n) (lambda (bs) (bit-string (bs :: binary))))
|
||||||
|
((_ #f) (lambda (bs) (bit-string (bs :: binary))))))
|
||||||
|
|
||||||
(define-syntax t:string
|
(define-syntax t:string
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
@ -137,7 +142,7 @@
|
||||||
(string #'((t:string #:pack)))
|
(string #'((t:string #:pack)))
|
||||||
(mpint #'((t:mpint)))
|
(mpint #'((t:mpint)))
|
||||||
(name-list #'((t:name-list)))
|
(name-list #'((t:name-list)))
|
||||||
(extension #'(binary))))
|
(extension #'((t:packed-bytes)))))
|
||||||
|
|
||||||
(define-syntax compute-ssh-message-encoder
|
(define-syntax compute-ssh-message-encoder
|
||||||
(lambda (stx)
|
(lambda (stx)
|
||||||
|
|
643
ssh-session.rkt
643
ssh-session.rkt
|
@ -15,12 +15,10 @@
|
||||||
(require "ssh-exceptions.rkt")
|
(require "ssh-exceptions.rkt")
|
||||||
(require "ssh-transport.rkt")
|
(require "ssh-transport.rkt")
|
||||||
|
|
||||||
(provide required-peer-identification-regex
|
(require "os2-support.rkt")
|
||||||
client-preamble-lines
|
|
||||||
client-identification-string
|
|
||||||
rekey-interval
|
|
||||||
rekey-volume
|
|
||||||
|
|
||||||
|
(provide rekey-interval
|
||||||
|
rekey-volume
|
||||||
ssh-session)
|
ssh-session)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -50,22 +48,19 @@
|
||||||
|
|
||||||
;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler.
|
;; A PacketDispatcher is a Hashtable mapping Byte to PacketHandler.
|
||||||
|
|
||||||
;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> ConnectionState).
|
;; A PacketHandler is a (Bytes DecodedPacket ConnectionState -> Transition).
|
||||||
;; The raw received bytes of the packet are given because sometimes
|
;; The raw received bytes of the packet are given because sometimes
|
||||||
;; cryptographic operations on the received bytes are mandated by the
|
;; cryptographic operations on the received bytes are mandated by the
|
||||||
;; protocol.
|
;; protocol.
|
||||||
|
|
||||||
;; A ConnectionState is a (connection StreamState StreamState
|
;; A ConnectionState is a (connection ... TODO fix this) representing
|
||||||
;; PacketDispatcher ... TODO fix this) representing the complete state
|
;; the complete state of the SSH transport, authentication, and
|
||||||
;; of the SSH transport, authentication, and connection layers.
|
;; connection layers.
|
||||||
(struct connection (io-room-handle
|
(struct connection (discard-next-packet?
|
||||||
session-room-handle
|
|
||||||
discard-next-packet?
|
|
||||||
dispatch-table
|
dispatch-table
|
||||||
total-transferred
|
total-transferred
|
||||||
rekey-state
|
rekey-state
|
||||||
authentication-state
|
authentication-state
|
||||||
continuations
|
|
||||||
channel-map
|
channel-map
|
||||||
is-server?
|
is-server?
|
||||||
local-id
|
local-id
|
||||||
|
@ -92,8 +87,7 @@
|
||||||
;; A ChannelState is a (ssh-channel ...) TODO
|
;; A ChannelState is a (ssh-channel ...) TODO
|
||||||
;; Named ssh-channel to avoid conflicts with Racket's built-in
|
;; Named ssh-channel to avoid conflicts with Racket's built-in
|
||||||
;; synchronous channels.
|
;; synchronous channels.
|
||||||
(struct ssh-channel (room-handle ;; RoomHandle
|
(struct ssh-channel (my-ref ;; Uint32
|
||||||
my-ref ;; Uint32
|
|
||||||
your-ref ;; Maybe<Uint32>
|
your-ref ;; Maybe<Uint32>
|
||||||
type ;; String
|
type ;; String
|
||||||
continuations ;; TransactionManager (see ordered-rpc.rkt)
|
continuations ;; TransactionManager (see ordered-rpc.rkt)
|
||||||
|
@ -118,15 +112,6 @@
|
||||||
;; Parameters
|
;; Parameters
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define identification-recogniser #rx"^SSH-")
|
|
||||||
(define (identification-line? str)
|
|
||||||
(regexp-match identification-recogniser str))
|
|
||||||
|
|
||||||
(define required-peer-identification-regex (make-parameter #rx"^SSH-2\\.0-.*"))
|
|
||||||
|
|
||||||
(define client-preamble-lines (make-parameter '()))
|
|
||||||
(define client-identification-string (make-parameter "SSH-2.0-RacketSSH_0.0"))
|
|
||||||
|
|
||||||
(define rekey-interval (make-parameter 3600))
|
(define rekey-interval (make-parameter 3600))
|
||||||
(define rekey-volume (make-parameter 1000000000))
|
(define rekey-volume (make-parameter 1000000000))
|
||||||
|
|
||||||
|
@ -158,20 +143,22 @@
|
||||||
(hash-remove d packet-type-number)))
|
(hash-remove d packet-type-number)))
|
||||||
(cddr key-value-pairs))))))
|
(cddr key-value-pairs))))))
|
||||||
|
|
||||||
;; ConnectionState [ Byte Maybe<PacketHandler> ]* -> ConnectionState
|
;; Transition [ Byte Maybe<PacketHandler> ]* -> ConnectionState
|
||||||
;; Installs (or removes) PacketHandlers in the given connection state;
|
;; Installs (or removes) PacketHandlers in the given connection state;
|
||||||
;; see extend-packet-dispatcher.
|
;; see extend-packet-dispatcher.
|
||||||
(define (set-handlers conn . key-value-pairs)
|
(define (set-handlers t . key-value-pairs)
|
||||||
(struct-copy connection conn
|
(extend-transition* t
|
||||||
[dispatch-table (apply extend-packet-dispatcher
|
(lambda (conn)
|
||||||
(connection-dispatch-table conn)
|
(struct-copy connection conn
|
||||||
key-value-pairs)]))
|
[dispatch-table (apply extend-packet-dispatcher
|
||||||
|
(connection-dispatch-table conn)
|
||||||
|
key-value-pairs)]))))
|
||||||
|
|
||||||
;; ConnectionState Byte PacketHandler -> ConnectionState
|
;; Transition Byte PacketHandler -> ConnectionState
|
||||||
;; Installs a PacketHandler that removes the installed dispatch entry
|
;; Installs a PacketHandler that removes the installed dispatch entry
|
||||||
;; and then delegates to its argument.
|
;; and then delegates to its argument.
|
||||||
(define (oneshot-handler conn packet-type-number packet-handler)
|
(define (oneshot-handler t packet-type-number packet-handler)
|
||||||
(set-handlers conn
|
(set-handlers t
|
||||||
packet-type-number
|
packet-type-number
|
||||||
(lambda (packet message conn)
|
(lambda (packet message conn)
|
||||||
(packet-handler packet
|
(packet-handler packet
|
||||||
|
@ -198,8 +185,8 @@
|
||||||
#f)))
|
#f)))
|
||||||
(if handler
|
(if handler
|
||||||
(handler packet message conn)
|
(handler packet message conn)
|
||||||
(begin (write-message!/flush (ssh-msg-unimplemented seq) conn)
|
(transition conn
|
||||||
conn)))))
|
(send-message (outbound-packet (ssh-msg-unimplemented seq))))))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Handlers for core transport packet types
|
;; Handlers for core transport packet types
|
||||||
|
@ -236,6 +223,10 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
|
(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
|
||||||
|
;; (transition conn
|
||||||
|
;; (send-message (set-timer 'rekey-timer
|
||||||
|
;; (* (rekey-wait-deadline rekey) 1000)
|
||||||
|
;; 'absolute)))]
|
||||||
(rekey-wait (+ (current-seconds) delta-seconds)
|
(rekey-wait (+ (current-seconds) delta-seconds)
|
||||||
(+ total-transferred delta-bytes)))
|
(+ total-transferred delta-bytes)))
|
||||||
|
|
||||||
|
@ -267,8 +258,8 @@
|
||||||
(define (dh-exchange-hash hash-info host-key e f k)
|
(define (dh-exchange-hash hash-info host-key e f k)
|
||||||
(let ((block-to-hash
|
(let ((block-to-hash
|
||||||
(bit-string->bytes
|
(bit-string->bytes
|
||||||
(bit-string ((string->bytes/utf-8 (exchange-hash-info-client-id hash-info)) :: (t:string))
|
(bit-string ((exchange-hash-info-client-id hash-info) :: (t:string))
|
||||||
((string->bytes/utf-8 (exchange-hash-info-server-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-client-kexinit-bytes hash-info) :: (t:string))
|
||||||
((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string))
|
((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string))
|
||||||
(host-key :: (t:string))
|
(host-key :: (t:string))
|
||||||
|
@ -279,11 +270,11 @@
|
||||||
|
|
||||||
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
||||||
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
||||||
;; -> ConnectionState
|
;; -> Transition
|
||||||
;; Performs the server's half of the Diffie-Hellman key exchange protocol.
|
;; Performs the server's half of the Diffie-Hellman key exchange protocol.
|
||||||
(define (perform-server-key-exchange hash-info kex-alg host-key-alg conn finish)
|
(define (perform-server-key-exchange hash-info kex-alg host-key-alg conn finish)
|
||||||
(case kex-alg
|
(case kex-alg
|
||||||
((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
|
[(diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
|
||||||
(define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
|
(define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
|
||||||
dh:oakley-group-14
|
dh:oakley-group-14
|
||||||
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
|
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
|
||||||
|
@ -310,51 +301,52 @@
|
||||||
(define h-signature (host-key-signature host-key-private
|
(define h-signature (host-key-signature host-key-private
|
||||||
host-key-alg
|
host-key-alg
|
||||||
exchange-hash))
|
exchange-hash))
|
||||||
(write-message!/flush (ssh-msg-kexdh-reply host-key-bytes
|
(prefix-transition (finish shared-secret exchange-hash hash-alg conn)
|
||||||
public-key-as-integer
|
(send-message (outbound-packet
|
||||||
h-signature)
|
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
|
||||||
conn)
|
public-key-as-integer
|
||||||
(finish shared-secret exchange-hash hash-alg conn))))
|
(bit-string->bytes h-signature)))))))]
|
||||||
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||||
"Bad key-exchange algorithm ~v" kex-alg))))
|
"Bad key-exchange algorithm ~v" kex-alg)]))
|
||||||
|
|
||||||
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
;; ExchangeHashInfo Symbol Symbol ConnectionState
|
||||||
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
;; (Bytes Bytes Symbol ConnectionState -> ConnectionState)
|
||||||
;; -> ConnectionState
|
;; -> Transition
|
||||||
;; Performs the client's half of the Diffie-Hellman key exchange protocol.
|
;; Performs the client's half of the Diffie-Hellman key exchange protocol.
|
||||||
(define (perform-client-key-exchange hash-info kex-alg host-key-alg conn finish)
|
(define (perform-client-key-exchange hash-info kex-alg host-key-alg conn finish)
|
||||||
(case kex-alg
|
(case kex-alg
|
||||||
((diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
|
[(diffie-hellman-group14-sha1 diffie-hellman-group1-sha1)
|
||||||
(define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
|
(define group (if (eq? kex-alg 'diffie-hellman-group14-sha1)
|
||||||
dh:oakley-group-14
|
dh:oakley-group-14
|
||||||
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
|
dh:oakley-group-2)) ;; yes, SSH's group1 == Oakley/RFC2409 group 2
|
||||||
(define-values (private-key public-key) (generate-key group))
|
(define-values (private-key public-key) (generate-key group))
|
||||||
(define public-key-as-integer (bit-string->integer public-key #t #f))
|
(define public-key-as-integer (bit-string->integer public-key #t #f))
|
||||||
(write-message!/flush (ssh-msg-kexdh-init public-key-as-integer) conn)
|
(prefix-transition
|
||||||
(oneshot-handler conn
|
(oneshot-handler conn
|
||||||
SSH_MSG_KEXDH_REPLY
|
SSH_MSG_KEXDH_REPLY
|
||||||
(lambda (packet message conn)
|
(lambda (packet message conn)
|
||||||
(define f (ssh-msg-kexdh-reply-f message))
|
(define f (ssh-msg-kexdh-reply-f message))
|
||||||
(define f-width (mpint-width f))
|
(define f-width (mpint-width f))
|
||||||
(define f-as-bytes (integer->bit-string f (* 8 f-width) #t))
|
(define f-as-bytes (integer->bit-string f (* 8 f-width) #t))
|
||||||
(define shared-secret (compute-key private-key f-as-bytes))
|
(define shared-secret (compute-key private-key f-as-bytes))
|
||||||
(define hash-alg sha1)
|
(define hash-alg sha1)
|
||||||
(define host-key-bytes (ssh-msg-kexdh-reply-host-key message))
|
(define host-key-bytes (ssh-msg-kexdh-reply-host-key message))
|
||||||
(define host-public-key
|
(define host-public-key
|
||||||
(pieces->public-key (ssh-host-key->pieces host-key-bytes)))
|
(pieces->public-key (ssh-host-key->pieces host-key-bytes)))
|
||||||
(define exchange-hash
|
(define exchange-hash
|
||||||
(dh-exchange-hash hash-info
|
(dh-exchange-hash hash-info
|
||||||
host-key-bytes
|
host-key-bytes
|
||||||
public-key-as-integer
|
public-key-as-integer
|
||||||
f
|
f
|
||||||
(bit-string->integer shared-secret #t #f)))
|
(bit-string->integer shared-secret #t #f)))
|
||||||
(verify-host-key-signature! host-public-key
|
(verify-host-key-signature! host-public-key
|
||||||
host-key-alg
|
host-key-alg
|
||||||
exchange-hash
|
exchange-hash
|
||||||
(ssh-msg-kexdh-reply-h-signature message))
|
(ssh-msg-kexdh-reply-h-signature message))
|
||||||
(finish shared-secret exchange-hash hash-alg conn))))
|
(finish shared-secret exchange-hash hash-alg conn)))
|
||||||
(else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
(send-message (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))))]
|
||||||
"Bad key-exchange algorithm ~v" kex-alg))))
|
[else (disconnect-with-error SSH_DISCONNECT_KEY_EXCHANGE_FAILED
|
||||||
|
"Bad key-exchange algorithm ~v" kex-alg)]))
|
||||||
|
|
||||||
;; PacketHandler for handling SSH_MSG_KEXINIT.
|
;; PacketHandler for handling SSH_MSG_KEXINIT.
|
||||||
(define (handle-msg-kexinit packet message conn)
|
(define (handle-msg-kexinit packet message conn)
|
||||||
|
@ -369,9 +361,6 @@
|
||||||
(define remote-algs message)
|
(define remote-algs message)
|
||||||
(define encoded-remote-algs packet)
|
(define encoded-remote-algs packet)
|
||||||
|
|
||||||
(when (rekey-wait? rekey)
|
|
||||||
(write-message!/flush local-algs conn))
|
|
||||||
|
|
||||||
(define is-server? (connection-is-server? conn))
|
(define is-server? (connection-is-server? conn))
|
||||||
(define c (if is-server? remote-algs local-algs))
|
(define c (if is-server? remote-algs local-algs))
|
||||||
(define s (if is-server? local-algs remote-algs))
|
(define s (if is-server? local-algs remote-algs))
|
||||||
|
@ -454,24 +443,31 @@
|
||||||
;; First, send our SSH_MSG_NEWKEYS,
|
;; First, send our SSH_MSG_NEWKEYS,
|
||||||
;; incrementing the various counters, and then
|
;; incrementing the various counters, and then
|
||||||
;; apply the new algorithms.
|
;; apply the new algorithms.
|
||||||
(write-message!/flush (ssh-msg-newkeys) conn)
|
(transition
|
||||||
(send (connection-io-room-handle conn) say
|
(set-handlers (struct-copy connection conn
|
||||||
(new-keys (connection-is-server? conn)
|
[rekey-state
|
||||||
derive-key
|
(rekey-in-seconds-or-bytes
|
||||||
c2s-enc s2c-enc
|
(rekey-interval)
|
||||||
c2s-mac s2c-mac
|
(rekey-volume)
|
||||||
c2s-zip s2c-zip))
|
(connection-total-transferred conn))])
|
||||||
(set-handlers (struct-copy connection conn
|
SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
|
||||||
[rekey-state
|
(send-message (outbound-packet (ssh-msg-newkeys)))
|
||||||
(rekey-in-seconds-or-bytes
|
(send-message
|
||||||
(rekey-interval)
|
(new-keys (connection-is-server? conn)
|
||||||
(rekey-volume)
|
derive-key
|
||||||
(connection-total-transferred conn))])
|
c2s-enc s2c-enc
|
||||||
SSH_MSG_SERVICE_REQUEST handle-msg-service-request))))
|
c2s-mac s2c-mac
|
||||||
|
c2s-zip s2c-zip))))))
|
||||||
|
|
||||||
(if should-discard-first-kex-packet
|
(let ((t (if should-discard-first-kex-packet
|
||||||
(struct-copy connection (continue-after-discard conn) [discard-next-packet? #t])
|
(struct-copy connection (continue-after-discard conn) [discard-next-packet? #t])
|
||||||
(continue-after-discard conn)))
|
(continue-after-discard conn))))
|
||||||
|
(prefix-transition* t
|
||||||
|
(lambda (conn)
|
||||||
|
(if (rekey-wait? (connection-rekey-state conn))
|
||||||
|
(transition (struct-copy connection conn [rekey-state (rekey-local local-algs)])
|
||||||
|
(send-message (outbound-packet local-algs)))
|
||||||
|
conn)))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Service request manager
|
;; Service request manager
|
||||||
|
@ -480,19 +476,18 @@
|
||||||
(define (handle-msg-service-request packet message conn)
|
(define (handle-msg-service-request packet message conn)
|
||||||
(define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
|
(define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
|
||||||
(match service
|
(match service
|
||||||
(#"ssh-userauth"
|
[#"ssh-userauth"
|
||||||
(if (connection-authentication-state conn)
|
(if (connection-authentication-state conn)
|
||||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||||
"Repeated authentication is not permitted")
|
"Repeated authentication is not permitted")
|
||||||
(begin
|
(prefix-transition (oneshot-handler conn
|
||||||
(write-message!/flush (ssh-msg-service-accept service) conn)
|
SSH_MSG_USERAUTH_REQUEST
|
||||||
(oneshot-handler conn
|
handle-msg-userauth-request)
|
||||||
SSH_MSG_USERAUTH_REQUEST
|
(send-message (outbound-packet (ssh-msg-service-accept service)))))]
|
||||||
handle-msg-userauth-request))))
|
[else
|
||||||
(else
|
|
||||||
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
|
||||||
"Service ~v not supported"
|
"Service ~v not supported"
|
||||||
service))))
|
service)]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; User authentication
|
;; User authentication
|
||||||
|
@ -502,218 +497,30 @@
|
||||||
(define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message)))
|
(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)))
|
(define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message)))
|
||||||
(cond
|
(cond
|
||||||
((and (positive? (bytes-length user-name))
|
[(and (positive? (bytes-length user-name))
|
||||||
(equal? service-name #"ssh-connection"))
|
(equal? service-name #"ssh-connection"))
|
||||||
;; TODO: Actually implement client authentication
|
;; TODO: Actually implement client authentication
|
||||||
(write-message!/flush (ssh-msg-userauth-success) conn)
|
(prefix-transition
|
||||||
(start-connection-service
|
(start-connection-service
|
||||||
(set-handlers (struct-copy connection conn
|
(set-handlers (struct-copy connection conn
|
||||||
[authentication-state (authenticated user-name service-name)])
|
[authentication-state (authenticated user-name service-name)])
|
||||||
SSH_MSG_USERAUTH_REQUEST
|
SSH_MSG_USERAUTH_REQUEST
|
||||||
(lambda (packet message conn)
|
(lambda (packet message conn)
|
||||||
;; RFC4252 section 5.1 page 6
|
;; RFC4252 section 5.1 page 6
|
||||||
conn))))
|
conn)))
|
||||||
(else
|
(send-message (outbound-packet (ssh-msg-userauth-success))))]
|
||||||
(write-message!/flush (ssh-msg-userauth-failure '(none) #f) conn)
|
[else
|
||||||
conn)))
|
(transition conn
|
||||||
|
(send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Channel management
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define (allocate-channel conn room type your-ref outbound-window outbound-packet-size)
|
|
||||||
(define my-ref (hash-count (connection-channel-map conn)))
|
|
||||||
(define ch (ssh-channel (join-room room 'session)
|
|
||||||
my-ref
|
|
||||||
your-ref
|
|
||||||
type
|
|
||||||
(make-transaction-manager)
|
|
||||||
outbound-window
|
|
||||||
outbound-packet-size
|
|
||||||
1048576 ;; TODO: parameterize? Make configurable by app?
|
|
||||||
'neither
|
|
||||||
'neither
|
|
||||||
))
|
|
||||||
(values ch
|
|
||||||
(struct-copy connection (send-initial-credit conn ch)
|
|
||||||
[channel-map (hash-set (connection-channel-map conn) my-ref ch)])))
|
|
||||||
|
|
||||||
(define (send-initial-credit conn ch)
|
|
||||||
(define remaining-window (ssh-channel-outbound-window ch))
|
|
||||||
(if (and remaining-window
|
|
||||||
(positive? remaining-window))
|
|
||||||
(channel-notify conn ch (credit 'app remaining-window))
|
|
||||||
conn))
|
|
||||||
|
|
||||||
(define (get-channel conn my-ref)
|
|
||||||
(hash-ref (connection-channel-map conn) my-ref))
|
|
||||||
|
|
||||||
(define (update-channel conn ch)
|
|
||||||
(struct-copy connection conn
|
|
||||||
[channel-map (hash-set (connection-channel-map conn) (ssh-channel-my-ref ch) ch)]))
|
|
||||||
|
|
||||||
(define (discard-channel ch conn)
|
|
||||||
(struct-copy connection conn
|
|
||||||
[channel-map (hash-remove (connection-channel-map conn) (ssh-channel-my-ref ch))]))
|
|
||||||
|
|
||||||
;; 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 ch conn action)
|
|
||||||
(define new-close-state (update-close-state (ssh-channel-close-state ch) action))
|
|
||||||
(case action
|
|
||||||
((local) (write-message!/flush (ssh-msg-channel-close (ssh-channel-your-ref ch))
|
|
||||||
conn))
|
|
||||||
((remote) (send (ssh-channel-room-handle ch) depart 'remote-closed)))
|
|
||||||
(if (eq? new-close-state 'both)
|
|
||||||
(discard-channel ch conn)
|
|
||||||
(update-channel conn (struct-copy ssh-channel ch
|
|
||||||
[close-state new-close-state]))))
|
|
||||||
|
|
||||||
(define (channel-notify conn ch message)
|
|
||||||
(send (ssh-channel-room-handle ch) say message)
|
|
||||||
conn)
|
|
||||||
|
|
||||||
(define (channel-request conn ch message k)
|
|
||||||
(update-channel conn
|
|
||||||
(struct-copy ssh-channel ch
|
|
||||||
[continuations (room-rpc (ssh-channel-room-handle ch)
|
|
||||||
(ssh-channel-continuations ch)
|
|
||||||
message
|
|
||||||
k)])))
|
|
||||||
|
|
||||||
(define (finish-channel-request ch conn txn message)
|
|
||||||
(define-values (worklist new-continuations)
|
|
||||||
(room-rpc-finish (ssh-channel-continuations ch) txn message))
|
|
||||||
(let loop ((worklist worklist)
|
|
||||||
(ch (struct-copy ssh-channel ch [continuations new-continuations]))
|
|
||||||
(conn conn))
|
|
||||||
(if (null? worklist)
|
|
||||||
(update-channel conn ch)
|
|
||||||
(let ((item (car worklist)))
|
|
||||||
(define-values (new-ch new-conn) (item ch conn))
|
|
||||||
(loop (cdr worklist) new-ch new-conn)))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Connection service
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
|
;; SKETCH-O
|
||||||
(define (start-connection-service conn)
|
(define (start-connection-service conn)
|
||||||
(set-handlers conn
|
|
||||||
;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
|
|
||||||
SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
|
|
||||||
SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-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))
|
|
||||||
|
|
||||||
(define (handle-msg-global-request packet message conn)
|
|
||||||
(log-error "TODO: Unimplemented: handle-msg-global-request")
|
|
||||||
conn)
|
conn)
|
||||||
|
|
||||||
(define (handle-msg-channel-open packet message conn)
|
|
||||||
(match-define (ssh-msg-channel-open channel-type*
|
|
||||||
sender-channel
|
|
||||||
initial-window-size
|
|
||||||
maximum-packet-size
|
|
||||||
extra-request-data*)
|
|
||||||
message)
|
|
||||||
(define channel-type (bit-string->bytes channel-type*))
|
|
||||||
(define extra-request-data (bit-string->bytes extra-request-data*))
|
|
||||||
(app-request conn
|
|
||||||
`(open-channel ,(connection-username conn) ,channel-type ,extra-request-data)
|
|
||||||
(lambda (reply conn)
|
|
||||||
(match reply
|
|
||||||
(`(ok ,(? room? room) ,(? bytes? extra-reply-data))
|
|
||||||
(let-values (((ch conn) (allocate-channel conn
|
|
||||||
room
|
|
||||||
channel-type
|
|
||||||
sender-channel
|
|
||||||
initial-window-size
|
|
||||||
maximum-packet-size)))
|
|
||||||
(write-message!/flush (ssh-msg-channel-open-confirmation
|
|
||||||
sender-channel
|
|
||||||
(ssh-channel-my-ref ch)
|
|
||||||
(ssh-channel-inbound-window ch)
|
|
||||||
(default-packet-limit) ;; TODO get from reader
|
|
||||||
extra-reply-data)
|
|
||||||
conn)
|
|
||||||
conn))
|
|
||||||
(`(error ,reason-code ,description)
|
|
||||||
(write-message!/flush (ssh-msg-channel-open-failure
|
|
||||||
sender-channel
|
|
||||||
reason-code
|
|
||||||
(string->bytes/utf-8 description)
|
|
||||||
#"")
|
|
||||||
conn)
|
|
||||||
conn)))))
|
|
||||||
|
|
||||||
(define (handle-msg-window-adjust packet message conn)
|
|
||||||
(match-define (ssh-msg-channel-window-adjust recipient-channel count) message)
|
|
||||||
(define ch (get-channel conn recipient-channel))
|
|
||||||
(channel-notify conn ch (credit 'app count)))
|
|
||||||
|
|
||||||
(define (handle-msg-channel-data packet message conn)
|
|
||||||
(match-define (ssh-msg-channel-data recipient-channel data*) message)
|
|
||||||
(define data (bit-string->bytes data*))
|
|
||||||
(define ch (get-channel conn recipient-channel))
|
|
||||||
(channel-notify conn ch `(data ,data)))
|
|
||||||
|
|
||||||
(define (handle-msg-channel-extended-data packet message conn)
|
|
||||||
(match-define (ssh-msg-channel-extended-data recipient-channel type-code data*) message)
|
|
||||||
(define data (bit-string->bytes data*))
|
|
||||||
(define ch (get-channel conn recipient-channel))
|
|
||||||
(channel-notify conn ch `(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)))
|
|
||||||
(update-channel (channel-notify conn ch `(eof))
|
|
||||||
(struct-copy ssh-channel ch
|
|
||||||
[eof-state (update-close-state (ssh-channel-eof-state ch)
|
|
||||||
'remote)])))
|
|
||||||
|
|
||||||
(define (handle-msg-channel-close packet message conn)
|
|
||||||
(define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message)))
|
|
||||||
(maybe-close-channel ch conn 'remote))
|
|
||||||
|
|
||||||
(define (handle-msg-channel-request packet message conn)
|
|
||||||
(match-define (ssh-msg-channel-request recipient-channel type* want-reply? data*) message)
|
|
||||||
(define type (bit-string->bytes type*))
|
|
||||||
(define data (bit-string->bytes data*))
|
|
||||||
(define ch (get-channel conn recipient-channel))
|
|
||||||
(if (not want-reply?)
|
|
||||||
(channel-notify conn ch `(notify ,type ,data))
|
|
||||||
(channel-request conn ch `(,type ,data)
|
|
||||||
(lambda (reply ch conn)
|
|
||||||
(define your-ref (ssh-channel-your-ref ch))
|
|
||||||
(write-message!/flush (match reply
|
|
||||||
('ok (ssh-msg-channel-success your-ref))
|
|
||||||
('error (ssh-msg-channel-failure your-ref)))
|
|
||||||
conn)
|
|
||||||
(values ch conn)))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Session main loop
|
;; Session main process
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (write-message! message conn)
|
|
||||||
(send (connection-io-room-handle conn) say message))
|
|
||||||
|
|
||||||
(define (flush-outbound-messages! conn)
|
|
||||||
(send (connection-io-room-handle conn) say 'flush))
|
|
||||||
|
|
||||||
(define (write-message!/flush message conn)
|
|
||||||
(write-message! message conn)
|
|
||||||
(flush-outbound-messages! conn))
|
|
||||||
|
|
||||||
(define (connection-username conn)
|
(define (connection-username conn)
|
||||||
(match (connection-authentication-state conn)
|
(match (connection-authentication-state conn)
|
||||||
((authenticated username servicename)
|
((authenticated username servicename)
|
||||||
|
@ -721,76 +528,11 @@
|
||||||
(else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
(else (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
|
||||||
"Not authenticated"))))
|
"Not authenticated"))))
|
||||||
|
|
||||||
(define (app-notify conn message)
|
(define (bump-total t amount)
|
||||||
(send (connection-session-room-handle conn) say message)
|
(extend-transition* t
|
||||||
conn)
|
|
||||||
|
|
||||||
(define (app-request conn message k)
|
|
||||||
(struct-copy connection conn
|
|
||||||
[continuations (room-rpc (connection-session-room-handle conn)
|
|
||||||
(connection-continuations conn)
|
|
||||||
message
|
|
||||||
k)]))
|
|
||||||
|
|
||||||
(define (finish-app-request conn txn message)
|
|
||||||
(define-values (worklist new-continuations)
|
|
||||||
(room-rpc-finish (connection-continuations conn) txn message))
|
|
||||||
(foldl (lambda (item conn) (item conn))
|
|
||||||
(struct-copy connection conn [continuations new-continuations])
|
|
||||||
worklist))
|
|
||||||
|
|
||||||
(define (maybe-send-disconnect-message! e conn)
|
|
||||||
(when (not (exn:fail:contract:protocol-originated-at-peer? e))
|
|
||||||
(write-message!/flush (ssh-msg-disconnect (exn:fail:contract:protocol-reason-code e)
|
|
||||||
(string->bytes/utf-8 (exn-message e))
|
|
||||||
#"")
|
|
||||||
conn)))
|
|
||||||
|
|
||||||
(define (bump-total amount conn)
|
|
||||||
(struct-copy connection conn [total-transferred (+ (connection-total-transferred conn) amount)]))
|
|
||||||
|
|
||||||
(define io-room-message-handler
|
|
||||||
(lambda (message)
|
|
||||||
(lambda (conn)
|
(lambda (conn)
|
||||||
(match message
|
(struct-copy connection conn
|
||||||
((arrived 'read-thread)
|
[total-transferred (+ (connection-total-transferred conn) amount)]))))
|
||||||
(send (connection-io-room-handle conn) say (credit 'read-thread 1))
|
|
||||||
conn)
|
|
||||||
((arrived _)
|
|
||||||
conn)
|
|
||||||
((and departure (departed who why))
|
|
||||||
(if (zero? (hash-count (connection-channel-map conn)))
|
|
||||||
;; No open or half-open channels. No point in complaining; just leave.
|
|
||||||
#f
|
|
||||||
;; At least one channel. Make more of a noise.
|
|
||||||
(disconnect-with-error/local-info departure
|
|
||||||
SSH_DISCONNECT_CONNECTION_LOST
|
|
||||||
"I/O error")))
|
|
||||||
((says _ amount 'output-byte-count)
|
|
||||||
;; writer reporting bytes transferred
|
|
||||||
(bump-total amount conn))
|
|
||||||
((says _ (received-packet seq packet message transferred-count) _)
|
|
||||||
(send (connection-io-room-handle conn) say (credit 'read-thread 1))
|
|
||||||
(bump-total
|
|
||||||
transferred-count
|
|
||||||
(if (connection-discard-next-packet? conn)
|
|
||||||
(struct-copy connection conn [discard-next-packet? #f])
|
|
||||||
(dispatch-packet seq packet message conn))))))))
|
|
||||||
|
|
||||||
(define session-room-message-handler
|
|
||||||
(lambda (message)
|
|
||||||
(lambda (conn)
|
|
||||||
(match message
|
|
||||||
((arrived _)
|
|
||||||
conn)
|
|
||||||
((and departure (departed _ _))
|
|
||||||
(disconnect-with-error/local-info
|
|
||||||
departure
|
|
||||||
SSH_DISCONNECT_BY_APPLICATION
|
|
||||||
"Application disconnected"))
|
|
||||||
((says _ (rpc-reply transaction message) _)
|
|
||||||
;; TODO: not cap-secure. Introduce sealers, or indirect.
|
|
||||||
(finish-app-request conn transaction message))))))
|
|
||||||
|
|
||||||
;; (K V A -> A) A Hash<K,V> -> A
|
;; (K V A -> A) A Hash<K,V> -> A
|
||||||
(define (hash-fold fn seed hash)
|
(define (hash-fold fn seed hash)
|
||||||
|
@ -798,91 +540,15 @@
|
||||||
(seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
|
(seed seed (fn (hash-iterate-key hash pos) (hash-iterate-value hash pos) seed)))
|
||||||
((not pos) seed)))
|
((not pos) seed)))
|
||||||
|
|
||||||
(define (channel-events conn)
|
(define (rekey-wrap t)
|
||||||
(hash-fold (lambda (my-ref ch evt)
|
(extend-transition* t
|
||||||
(choice-evt evt
|
|
||||||
(handle-evt (send (ssh-channel-room-handle ch) listen-evt)
|
|
||||||
(channel-room-message-handler my-ref))))
|
|
||||||
never-evt
|
|
||||||
(connection-channel-map conn)))
|
|
||||||
|
|
||||||
(define (channel-room-message-handler my-ref)
|
|
||||||
(lambda (message)
|
|
||||||
(lambda (conn)
|
(lambda (conn)
|
||||||
(define ch (get-channel conn my-ref))
|
|
||||||
(define your-ref (ssh-channel-your-ref ch))
|
|
||||||
(match message
|
|
||||||
((arrived _)
|
|
||||||
conn)
|
|
||||||
((departed _ _)
|
|
||||||
(maybe-close-channel ch conn 'local))
|
|
||||||
((says _ (credit _ amount) _)
|
|
||||||
(write-message!/flush (ssh-msg-channel-window-adjust your-ref amount) conn)
|
|
||||||
conn)
|
|
||||||
((says _ `(data ,bits) _)
|
|
||||||
(write-message!/flush (ssh-msg-channel-data your-ref bits) conn)
|
|
||||||
conn)
|
|
||||||
((says _ `(eof) _)
|
|
||||||
(write-message!/flush (ssh-msg-channel-eof your-ref) conn)
|
|
||||||
conn)
|
|
||||||
((says _ (rpc-reply id m) _)
|
|
||||||
(finish-channel-request ch conn id m))))))
|
|
||||||
|
|
||||||
(define (run-ssh-session conn)
|
|
||||||
(with-handlers
|
|
||||||
((exn:fail:contract:protocol? (lambda (e)
|
|
||||||
(maybe-send-disconnect-message! e conn)
|
|
||||||
(raise e))))
|
|
||||||
(let loop ((conn conn))
|
|
||||||
(define rekey (connection-rekey-state conn))
|
(define rekey (connection-rekey-state conn))
|
||||||
(if (time-to-rekey? rekey conn)
|
(if (time-to-rekey? rekey conn)
|
||||||
(let ((algs ((local-algorithm-list))))
|
(let ((algs ((local-algorithm-list))))
|
||||||
(write-message!/flush algs conn)
|
(transition (struct-copy connection conn [rekey-state (rekey-local algs)])
|
||||||
(loop (struct-copy connection conn [rekey-state (rekey-local algs)])))
|
(send-message (outbound-packet algs))))
|
||||||
(let ((handler (sync (if (rekey-wait? rekey)
|
conn))))
|
||||||
(handle-evt (alarm-evt (* (rekey-wait-deadline rekey) 1000))
|
|
||||||
(lambda (dummy)
|
|
||||||
(lambda (conn)
|
|
||||||
conn)))
|
|
||||||
never-evt)
|
|
||||||
(handle-evt (send (connection-io-room-handle conn) listen-evt)
|
|
||||||
io-room-message-handler)
|
|
||||||
(handle-evt (send (connection-session-room-handle conn) listen-evt)
|
|
||||||
session-room-message-handler)
|
|
||||||
(channel-events conn))))
|
|
||||||
(define new-conn (handler conn))
|
|
||||||
;; The handler is permitted to return #f to indicate that the session is to be
|
|
||||||
;; gracefully shut down.
|
|
||||||
(when new-conn
|
|
||||||
(loop new-conn)))))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Session choreography
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define (send-preamble-and-identification! out)
|
|
||||||
(let ((my-id (client-identification-string)))
|
|
||||||
(for-each (lambda (line)
|
|
||||||
(when (identification-line? line)
|
|
||||||
(error 'ssh-session
|
|
||||||
"Client preamble includes forbidden line ~v"
|
|
||||||
line))
|
|
||||||
(display line out)
|
|
||||||
(display "\r\n" out))
|
|
||||||
(client-preamble-lines))
|
|
||||||
(display my-id out)
|
|
||||||
(display "\r\n" out)
|
|
||||||
(flush-output out)
|
|
||||||
my-id))
|
|
||||||
|
|
||||||
;; Port -> String
|
|
||||||
(define (read-preamble-and-identification! in)
|
|
||||||
(let ((line (read-line-limited in 253))) ;; 255 incl CRLF
|
|
||||||
(when (eof-object? line)
|
|
||||||
(error 'ssh-session "EOF while reading connection preamble"))
|
|
||||||
(if (identification-line? line)
|
|
||||||
line
|
|
||||||
(read-preamble-and-identification! in))))
|
|
||||||
|
|
||||||
;; PacketDispatcher. Handles the core transport message types.
|
;; PacketDispatcher. Handles the core transport message types.
|
||||||
(define base-packet-dispatcher
|
(define base-packet-dispatcher
|
||||||
|
@ -892,43 +558,36 @@
|
||||||
SSH_MSG_DEBUG handle-msg-debug
|
SSH_MSG_DEBUG handle-msg-debug
|
||||||
SSH_MSG_KEXINIT handle-msg-kexinit))
|
SSH_MSG_KEXINIT handle-msg-kexinit))
|
||||||
|
|
||||||
(define (ssh-session role in out)
|
(define (ssh-session local-identification-string
|
||||||
(define io-room (make-room (gensym 'ssh-io-room)))
|
peer-identification-string
|
||||||
;;(spy-on io-room)
|
session-role)
|
||||||
(define session-room (make-room (gensym 'ssh-session-room)))
|
(lambda (self-pid)
|
||||||
;;(spy-on session-room)
|
(transition (connection #f
|
||||||
|
base-packet-dispatcher
|
||||||
|
0
|
||||||
|
(rekey-in-seconds-or-bytes -1 -1 0)
|
||||||
|
#f
|
||||||
|
(hash)
|
||||||
|
(case session-role ((client) #f) ((server) #t))
|
||||||
|
local-identification-string
|
||||||
|
peer-identification-string
|
||||||
|
#f)
|
||||||
|
(role 'rekey-waiter (topic-subscriber (timer-expired 'rekey-timer (wild)))
|
||||||
|
#:state conn
|
||||||
|
[(timer-expired 'rekey-timer now)
|
||||||
|
(rekey-wrap conn)])
|
||||||
|
|
||||||
(define local-identification-string (send-preamble-and-identification! out))
|
(role 'credit-listener (topic-subscriber (outbound-byte-credit (wild)))
|
||||||
(define peer-identification-string (read-preamble-and-identification! in))
|
#:state conn
|
||||||
|
[(outbound-byte-credit amount)
|
||||||
|
(rekey-wrap (bump-total conn amount))])
|
||||||
|
|
||||||
;; Each identification string is both a cleartext indicator that
|
(role 'packet-listener (topic-subscriber (inbound-packet (wild) (wild) (wild) (wild)))
|
||||||
;; we've reached some notion of the right place and also input to
|
#:state conn
|
||||||
;; the hash function used during D-H key exchange.
|
[(inbound-packet sequence-number payload message transfer-size)
|
||||||
(when (not (regexp-match (required-peer-identification-regex)
|
(let* ((t (if (connection-discard-next-packet? conn)
|
||||||
peer-identification-string))
|
(struct-copy connection conn [discard-next-packet? #f])
|
||||||
(display "Invalid identification\r\n" out)
|
(dispatch-packet sequence-number payload message conn)))
|
||||||
(flush-output out)
|
(t (bump-total t transfer-size))
|
||||||
(error 'ssh-session
|
(t (extend-transition t (send-message (inbound-credit 1)))))
|
||||||
"Invalid peer identification string ~v"
|
(rekey-wrap t))]))))
|
||||||
peer-identification-string))
|
|
||||||
|
|
||||||
(standard-thread (lambda () (ssh-reader in io-room)))
|
|
||||||
(standard-thread (lambda () (ssh-writer out io-room)))
|
|
||||||
(wait-for-members io-room '(read-thread write-thread))
|
|
||||||
(standard-thread
|
|
||||||
(lambda ()
|
|
||||||
(run-ssh-session (connection (join-room io-room 'session)
|
|
||||||
(join-room session-room 'session)
|
|
||||||
#f
|
|
||||||
base-packet-dispatcher
|
|
||||||
0
|
|
||||||
(rekey-in-seconds-or-bytes -1 -1 0)
|
|
||||||
#f
|
|
||||||
(make-transaction-manager)
|
|
||||||
(hash)
|
|
||||||
(case role ((client) #f) ((server) #t))
|
|
||||||
local-identification-string
|
|
||||||
peer-identification-string
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(join-room session-room 'app))
|
|
||||||
|
|
Loading…
Reference in New Issue