Push through to channel layer

This commit is contained in:
Tony Garnock-Jones 2021-06-15 14:52:21 +02:00
parent 5479511afa
commit 4e1d525904
4 changed files with 273 additions and 262 deletions

View File

@ -25,7 +25,7 @@
(spawn-tcp-driver ds)
(spawn #:name 'ssh-tcp-listener
(at ds
(during/spawn (Connection $conn (TcpInbound "0.0.0.0" 29418))
(during/spawn (Connection $conn (TcpLocal "0.0.0.0" 29418))
#:name (list 'ssh conn)
(session ds conn))))))
@ -43,66 +43,69 @@
peer-identification-string)))
(define (session ground-ds conn)
(define root-facet this-facet)
(define update-input-handler
(accept-connection conn
#:initial-credit #f
#:on-data (lambda (input mode) (error 'session "Unexpected input"))))
(define local-identification #"SSH-2.0-RacketSSH_0.0")
(send-line conn local-identification)
(send-lines-credit conn 1 (LineMode-crlf))
(update-input-handler
#:on-data (lambda (remote-identification _mode)
(check-remote-identification! remote-identification)
(define id-line-reader-facet
(react
(on-start (send-line conn local-identification)
(send-lines-credit conn 1 (LineMode-crlf)))
(accept-connection conn
#:initial-credit #f
#:on-eof (lambda () (stop-current-facet))
#:on-data (lambda (remote-identification _mode)
(check-remote-identification! remote-identification)
(send! session-vm-factory remote-identification)))))
(define session-vm
(actor-group [(on-stop
(stop-facet root-facet)
(log-info "Session VM for ~a closed" conn))]
(define conn-ds (dataspace #:name (gensym 'conn-ds)))
(define transfer-control
(object #:name 'transfer-control
[#:message 'transfer-control (stop-facet id-line-reader-facet)]))
(spawn/link #:name 'reader
(ssh-reader conn-ds conn update-input-handler))
(spawn/link #:name 'writer
(ssh-writer conn-ds conn))
(define session-vm-factory
(object
#:name 'session-vm-factory
[#:message remote-identification
(on-stop (log-info "Session VM for ~a closed" conn))
(actor-group
#:link? #t
(define conn-ds (dataspace #:name (gensym 'conn-ds)))
;; Wait for the reader and writer get started, then tell the reader
;; we are ready for a single packet and spawn the session manager.
(react
(at conn-ds
(stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _))
(send! conn-ds (inbound-credit 1))
(spawn #:name 'reader (ssh-reader conn-ds conn transfer-control))
(spawn #:name 'writer (ssh-writer conn-ds conn))
(spawn/link
#:name 'session
(ssh-session conn-ds
ground-ds
local-identification
remote-identification
(lambda (user-name)
(error 'repl-boot "Would start session with ~a" user-name))
'server)))))
;; Wait for the reader and writer get started, then tell the reader
;; we are ready for a single packet and spawn the session manager.
(react
(at conn-ds
(stop-when (asserted (Observe (:pattern (inbound-credit ,_)) _))
(send! conn-ds (inbound-credit 1))
(at conn-ds
;; (during $m
;; (on-start (log-info "++ ~v" m))
;; (on-stop (log-info "-- ~v" m)))
(when (message $m)
(log-info ">> ~v" m)))
(spawn
#:name 'session
(ssh-session conn-ds
ground-ds
local-identification
remote-identification
(lambda (user-name)
(error 'repl-boot "Would start session with ~a" user-name))
'server)))))
(at conn-ds
(when (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
(when (not originated-at-peer?)
(send! conn-ds
(outbound-packet (ssh-msg-disconnect reason-code
(string->bytes/utf-8 message)
#""))))
(actor-system-shutdown! session-vm)))))
;; (at conn-ds
;; ;; (during $m
;; ;; (on-start (log-info "++ ~v" m))
;; ;; (on-stop (log-info "-- ~v" m)))
;; (when (message $m)
;; (log-info ">> ~v" m)))
(void))))
(at conn-ds
(when (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
(when (not originated-at-peer?)
(send! conn-ds
(outbound-packet (ssh-msg-disconnect reason-code
(string->bytes/utf-8 message)
#""))))
(sync! conn-ds (stop-actor-system)))))]))
(void))
;;---------------------------------------------------------------------------

View File

@ -58,9 +58,6 @@
(case host-key-alg
[(ssh-ed25519)
(define signature (pk-sign private-key exchange-hash))
(log-info "signature length ~a value ~v verifies"
(bytes-length signature)
signature)
(bit-string (#"ssh-ed25519" :: (t:string))
(signature :: (t:string)))]))

View File

@ -69,6 +69,36 @@
(struct task (seq packet-type packet message) #:prefab)
(struct task-complete (seq) #:prefab)
(define-event-expander with-incoming-task
(syntax-rules ()
[(_ (seq-id type-byte packet-pattern message-pattern) body ...)
(with-incoming-task* when (seq-id type-byte packet-pattern message-pattern) body ...)]))
(define-syntax-rule
(with-incoming-task/react conn-ds (seq-id type-byte packet-pattern message-pattern) body ...)
(react
(at conn-ds
(with-incoming-task* stop-when (seq-id type-byte packet-pattern message-pattern)
body ...))))
(define-event-expander with-incoming-task*
(syntax-rules ()
[(_ when-stx (seq-id type-byte packet-pattern message-pattern) body ...)
(when-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern))
body ...
(send! this-target (task-complete seq-id)))]))
(define-syntax-rule (with-assertion-presence ds assertion
#:on-present [body-present ...]
#:on-absent [body-absent ...])
(let ((assertion-present #f))
(at ds (when (asserted assertion)
(set! assertion-present #t)
body-present ...))
(sync! ds (when (not assertion-present)
(void)
body-absent ...))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Key Exchange
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -120,29 +150,24 @@
(define private-key (generate-private-key group))
(match-define (list 'dh 'public p g public-key-as-integer)
(pk-key->datum private-key 'rkt-public))
(react
(at conn-ds
(when (message (task $seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e)))
(define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public))
(define shared-secret (pk-derive-secret private-key peer-key))
(define hash-alg sha256)
(define-values (host-key-private host-key-public)
(host-key-algorithm->keys host-key-alg))
(define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public)))
(define exchange-hash (dh-exchange-hash hash-alg
hash-info
host-key-bytes
e
public-key-as-integer
(bit-string->integer shared-secret #t #f)))
(define h-signature (host-key-signature host-key-private host-key-alg exchange-hash))
(log-info "h-signature ~v public-key-as-integer ~v" h-signature public-key-as-integer)
(send! conn-ds (outbound-packet
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
public-key-as-integer
(bit-string->bytes h-signature))))
(send! conn-ds (task-complete seq))
(finish shared-secret exchange-hash hash-alg))))]
(with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e))
(define peer-key (datum->pk-key (list 'dh 'public p g e) 'rkt-public))
(define shared-secret (pk-derive-secret private-key peer-key))
(define hash-alg sha256)
(define-values (host-key-private host-key-public) (host-key-algorithm->keys host-key-alg))
(define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public)))
(define exchange-hash (dh-exchange-hash hash-alg
hash-info
host-key-bytes
e
public-key-as-integer
(bit-string->integer shared-secret #t #f)))
(define h-signature (host-key-signature host-key-private host-key-alg exchange-hash))
(send! conn-ds (outbound-packet
(ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
public-key-as-integer
(bit-string->bytes h-signature))))
(finish shared-secret exchange-hash hash-alg))]
[_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
"Bad key-exchange algorithm ~v" kex-alg)]))
@ -156,23 +181,20 @@
(match-define (list 'dh 'public p g public-key-as-integer)
(pk-key->datum private-key 'rkt-public))
(send! conn-ds (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
(react
(at conn-ds
(when (message (task $seq SSH_MSG_KEXDH_REPLY _
(ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)))
(define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public))
(define shared-secret (pk-derive-secret private-key peer-key))
(define hash-alg sha256)
(define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes)))
(define exchange-hash (dh-exchange-hash hash-alg
hash-info
host-key-bytes
public-key-as-integer
f
(bit-string->integer shared-secret #t #f)))
(verify-host-key-signature! host-public-key host-key-alg exchange-hash h-signature)
(send! conn-ds (task-complete seq))
(finish shared-secret exchange-hash hash-alg))))]
(with-incoming-task/react conn-ds (seq SSH_MSG_KEXDH_REPLY _
(ssh-msg-kexdh-reply $host-key-bytes $f $h-signature))
(define peer-key (datum->pk-key (list 'dh 'public p g f) 'rkt-public))
(define shared-secret (pk-derive-secret private-key peer-key))
(define hash-alg sha256)
(define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes)))
(define exchange-hash (dh-exchange-hash hash-alg
hash-info
host-key-bytes
public-key-as-integer
f
(bit-string->integer shared-secret #t #f)))
(verify-host-key-signature! host-public-key host-key-alg exchange-hash h-signature)
(finish shared-secret exchange-hash hash-alg))]
[_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
"Bad key-exchange algorithm ~v" kex-alg)]))
@ -266,78 +288,65 @@
(extend (bytes-append key (hash-alg (bit-string->bytes
(bit-string (k-h-prefix :: binary)
(key :: binary))))))))))
(react
(at conn-ds
(when (message (task $seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys)))
;; First, send our SSH_MSG_NEWKEYS, incrementing the
;; various counters, and then apply the new algorithms.
;; Also arm our rekey timer.
(rekey-state (rekey-in-seconds-or-bytes (rekey-interval)
(rekey-volume)
(total-transferred)))
(send! conn-ds 'enable-service-request!)
(send! conn-ds (outbound-packet (ssh-msg-newkeys)))
(send! conn-ds (new-keys is-server?
(embedded derive-key)
c2s-enc s2c-enc
c2s-mac s2c-mac
c2s-zip s2c-zip))
(send! ground-ds (SetTimer 'rekey-timer
(* (rekey-wait-deadline (rekey-state)) 1000)
(TimerKind-absolute)))
(send! conn-ds (task-complete seq))))))))
(with-incoming-task/react conn-ds (seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys))
;; First, send our SSH_MSG_NEWKEYS, incrementing the
;; various counters, and then apply the new algorithms.
;; Also arm our rekey timer.
(rekey-state (rekey-in-seconds-or-bytes (rekey-interval)
(rekey-volume)
(total-transferred)))
(send! conn-ds 'enable-service-request-handler)
(send! conn-ds (outbound-packet (ssh-msg-newkeys)))
(send! conn-ds (new-keys is-server?
(embedded derive-key)
c2s-enc s2c-enc
c2s-mac s2c-mac
c2s-zip s2c-zip))
(send! ground-ds (SetTimer 'rekey-timer
(* (rekey-wait-deadline (rekey-state)) 1000)
(TimerKind-absolute)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Service request manager
;; Service request manager and user authentication
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (define (handle-msg-service-request packet message conn)
;; (define service (bit-string->bytes (ssh-msg-service-request-service-name message)))
;; (match service
;; [#"ssh-userauth"
;; (if (connection-authentication-state conn)
;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
;; "Repeated authentication is not permitted")
;; (sequence-actions (transition conn)
;; (send-message (outbound-packet (ssh-msg-service-accept service)))
;; (lambda (conn) (transition
;; (oneshot-handler conn
;; SSH_MSG_USERAUTH_REQUEST
;; handle-msg-userauth-request)))))]
;; [else
;; (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
;; "Service ~v not supported"
;; service)]))
(define (service-request-handler conn-ds)
(define-field authentication-state #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User authentication
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(at conn-ds
(assert #:when (authentication-state) (authentication-state))
;; (define (handle-msg-userauth-request packet message conn)
;; (define user-name (bit-string->bytes (ssh-msg-userauth-request-user-name message)))
;; (define service-name (bit-string->bytes (ssh-msg-userauth-request-service-name message)))
;; (cond
;; [(and (positive? (bytes-length user-name))
;; (equal? service-name #"ssh-connection"))
;; ;; TODO: Actually implement client authentication
;; (sequence-actions (transition conn)
;; (send-message (outbound-packet (ssh-msg-userauth-success)))
;; (lambda (conn)
;; (start-connection-service
;; (set-handlers (struct-copy connection conn
;; [authentication-state (authenticated user-name service-name)])
;; SSH_MSG_USERAUTH_REQUEST
;; (lambda (packet message conn)
;; ;; RFC4252 section 5.1 page 6
;; conn))))
;; (lambda (conn)
;; (transition conn
;; ;; TODO: canary for NESTED VM!: #:exit-signal? #t
;; (spawn-vm #:debug-name 'ssh-application-vm
;; ((connection-application-boot conn) user-name)))))]
;; [else
;; (transition conn
;; (send-message (outbound-packet (ssh-msg-userauth-failure '(none) #f))))]))
(with-incoming-task (seq SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service))
(match service
[#"ssh-userauth"
(cond
[(authentication-state)
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
"Repeated authentication is not permitted")]
[else
(send! conn-ds (outbound-packet (ssh-msg-service-accept service)))
(with-incoming-task/react conn-ds
(seq SSH_MSG_USERAUTH_REQUEST _
(ssh-msg-userauth-request $user-name $service-name _ _))
(cond
[(and (positive? (bytes-length user-name))
(equal? service-name #"ssh-connection"))
;; TODO: Actually implement client authentication
(send! conn-ds (outbound-packet (ssh-msg-userauth-success)))
(authentication-state (authenticated user-name service-name))
(react
(at conn-ds
(with-incoming-task (seq SSH_MSG_USERAUTH_REQUEST _ _)
;; RFC4252 section 5.1 page 6
)))
(let ((a (authentication-state)))
(spawn #:name 'connection-service (start-connection-service conn-ds a)))]
[else
(send! conn-ds (outbound-packet (ssh-msg-userauth-failure '(none) #f)))]))])]
[_
(disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
"Service ~v not supported"
service)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Channel management
@ -518,65 +527,78 @@
;; '())))
;; (transition conn)))
;; (define (start-connection-service conn)
;; (sequence-actions
;; (transition
;; (set-handlers conn
;; ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
;; SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation
;; SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure
;; SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust
;; SSH_MSG_CHANNEL_DATA handle-msg-channel-data
;; SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
;; SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
;; SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
;; SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request
;; SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success
;; SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure))
;; ;; Start responding to channel interest coming from the
;; ;; application. We are responding to channels appearing from the
;; ;; remote peer by virtue of our installation of the handler for
;; ;; SSH_MSG_CHANNEL_OPEN above.
;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
;; (match-state conn
;; (match-conversation (channel-message (channel-stream-name #t cname) _)
;; (on-presence (respond-to-opened-outbound-channel conn cname)))))
;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
;; (match-state conn
;; (match-conversation (channel-message (channel-stream-name #f cname) _)
;; (on-presence (respond-to-opened-outbound-channel conn cname)))))))
(define (start-connection-service conn-ds authentication)
(match-define (authenticated user-name _service-name) authentication)
;; (define (handle-msg-channel-open packet message conn)
;; (match-define (ssh-msg-channel-open channel-type*
;; remote-ref
;; initial-window-size
;; maximum-packet-size
;; extra-request-data*)
;; message)
(handle-msg-channel-open conn-ds)
;; (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref))
;; (connection-channels conn))
;; (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
;; "Attempt to open already-open channel ~v"
;; remote-ref))
;; (set-handlers conn
;; ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request
;; SSH_MSG_CHANNEL_OPEN handle-msg-channel-open
;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation
;; SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure
;; SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust
;; SSH_MSG_CHANNEL_DATA handle-msg-channel-data
;; SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data
;; SSH_MSG_CHANNEL_EOF handle-msg-channel-eof
;; SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close
;; SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request
;; SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success
;; SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure))
;; (define channel-type (bit-string->bytes channel-type*))
;; (define extra-request-data (bit-string->bytes extra-request-data*))
;; (define cname (channel-name #f channel-type remote-ref))
;; (at conn-ds
;; (during ...))
;; ;; Start responding to channel interest coming from the
;; ;; application. We are responding to channels appearing from the
;; ;; remote peer by virtue of our installation of the handler for
;; ;; SSH_MSG_CHANNEL_OPEN above.
;; (observe-subscribers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
;; (match-state conn
;; (match-conversation (channel-message (channel-stream-name #t cname) _)
;; (on-presence (respond-to-opened-outbound-channel conn cname)))))
;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
;; (match-state conn
;; (match-conversation (channel-message (channel-stream-name #f cname) _)
;; (on-presence (respond-to-opened-outbound-channel conn cname)))))
(void)
)
;; (transition (update-channel cname
;; (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
;; conn)
;; (channel-endpoints cname
;; (lambda (inbound-stream outbound-stream)
;; (list (send-feedback
;; (channel-message outbound-stream
;; (channel-stream-config maximum-packet-size
;; extra-request-data)))
;; (send-feedback
;; (channel-message outbound-stream
;; (channel-stream-credit initial-window-size))))))))
(define (handle-msg-channel-open conn-ds)
(void)
;; (at conn-ds
;; (with-incoming-task (seq SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type
;; $remote-ref
;; $initial-window-size
;; $maximum-packet-size
;; $extra-request-data))
;; (react
;; (at conn-ds
;; (when (asserted (Observe (:pattern (
;; (sync! conn-ds
;; (
;; (when (memf (lambda (c) (equal? (ssh-channel-remote-ref c) remote-ref))
;; (connection-channels conn))
;; (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR
;; "Attempt to open already-open channel ~v"
;; remote-ref))
;; (define channel-type (bit-string->bytes channel-type*))
;; (define extra-request-data (bit-string->bytes extra-request-data*))
;; (define cname (channel-name #f channel-type remote-ref))
;; (transition (update-channel cname
;; (lambda (e) (struct-copy ssh-channel e [remote-ref remote-ref]))
;; conn)
;; (channel-endpoints cname
;; (lambda (inbound-stream outbound-stream)
;; (list (send-feedback
;; (channel-message outbound-stream
;; (channel-stream-config maximum-packet-size
;; extra-request-data)))
;; (send-feedback
;; (channel-message outbound-stream
;; (channel-stream-credit initial-window-size))))))))
)
;; (define (handle-msg-channel-open-confirmation packet message conn)
;; (match-define (ssh-msg-channel-open-confirmation local-ref
@ -674,59 +696,48 @@
(define-field total-transferred 0)
(define-field discard-next-packet? #f)
(define authentication-state #f)
(define channels '())
(define is-server? (case session-role ((client) #f) ((server) #t)))
(at conn-ds
(when (message (task $seq SSH_MSG_DISCONNECT _
(ssh-msg-disconnect $reason-code $description $language-tag)))
(with-incoming-task (seq SSH_MSG_DISCONNECT _
(ssh-msg-disconnect $reason-code $description $language-tag))
(disconnect-with-error* conn-ds #t
'()
reason-code
"Received SSH_MSG_DISCONNECT with reason code ~a and message ~s"
reason-code
(bytes->string/utf-8 (bit-string->bytes description)))
(send! conn-ds (task-complete seq)))
(bytes->string/utf-8 (bit-string->bytes description))))
(when (message (task $seq SSH_MSG_IGNORE _ (ssh-msg-ignore _)))
(send! conn-ds (task-complete seq)))
(with-incoming-task (seq SSH_MSG_IGNORE _ (ssh-msg-ignore _)))
(when (message (task $seq SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq)))
(with-incoming-task (seq SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq))
(disconnect-with-error/local-info
conn-ds
`((offending-sequence-number ,peer-seq))
SSH_DISCONNECT_PROTOCOL_ERROR
"Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")
(send! conn-ds (task-complete seq)))
"Disconnecting because of received SSH_MSG_UNIMPLEMENTED."))
(when (message (task $seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _))))
(log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))
(send! conn-ds (task-complete seq)))
(with-incoming-task (seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _)))
(log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)))
(when (message (task $seq SSH_MSG_KEXINIT $packet
($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))))
(with-incoming-task (seq SSH_MSG_KEXINIT $packet
($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _)))
(do-kexinit conn-ds
ground-ds
#:packet packet
#:message message
#:rekey-state rekey-state
#:is-server? is-server?
#:is-server? (case session-role ((client) #f) ((server) #t))
#:local-id local-identification-string
#:remote-id peer-identification-string
#:session-id session-id
#:total-transferred total-transferred
#:discard-next-packet? discard-next-packet?)
(send! conn-ds (task-complete seq)))
#:discard-next-packet? discard-next-packet?)))
(when (message 'enable-service-request!)
(log-info "Saw enable-service-request!")
;; TODO::
;; (set-handlers
;; (struct-copy connection conn [rekey-state new-rekey-state])
;; SSH_MSG_SERVICE_REQUEST handle-msg-service-request)
)
)
(react
(at conn-ds
(stop-when (message 'enable-service-request-handler)
(spawn #:name 'service-request-handler (service-request-handler conn-ds)))))
(define (maybe-rekey)
(match (rekey-state)
@ -768,14 +779,11 @@
(react
(on-start
(send! conn-ds (task sequence-number packet-type-number payload message)))
(let ((handler-present #f))
(at conn-ds
(when (asserted (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _))
(set! handler-present #t)))
(sync! conn-ds
(when (not handler-present)
(send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number)))
(send! conn-ds (task-complete sequence-number)))))
(with-assertion-presence conn-ds
(Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _)
#:on-present []
#:on-absent [(send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number)))
(send! conn-ds (task-complete sequence-number))])
(at conn-ds (stop-when (message (task-complete sequence-number))))
(on-stop (send! conn-ds (inbound-credit 1)))))))
(total-transferred (+ (total-transferred) transfer-size))

View File

@ -258,7 +258,14 @@
;; Encrypted Packet Input
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (ssh-reader conn-ds conn update-input-handler)
(define (ssh-reader conn-ds conn transfer-control)
(define input-handler #f)
(define (update-input-handler #:on-data proc) (set! input-handler proc))
(assert-control conn
#:on-eof (lambda () (stop-current-facet))
#:on-data (lambda (data mode) (input-handler data mode)))
(send! transfer-control 'transfer-control)
(define packet-size-limit (default-packet-limit))
(define sequence-number 0)
(define remaining-credit 0)
@ -274,7 +281,7 @@
(define (issue-credit)
(when (positive? remaining-credit)
(send-bytes-credit conn (block-size))))
(send-packet-credit conn (block-size))))
(define (handle-packet-header encrypted-packet _mode)
(define first-block (decrypt-chunk encrypted-packet))
@ -284,11 +291,11 @@
(define remaining-to-read (- packet-length amount-of-packet-in-first-block))
(if (positive? remaining-to-read)
(begin
(send-bytes-credit conn remaining-to-read)
(send-packet-credit conn remaining-to-read)
(update-input-handler
#:on-data (lambda (encrypted-packet _mode)
(check-hmac (bytes-append first-block (decrypt-chunk encrypted-packet))
packet-length))))
(define subsequent-chunk (decrypt-chunk encrypted-packet))
(check-hmac (bytes-append first-block subsequent-chunk) packet-length))))
(check-hmac first-block packet-length)))
(define (check-hmac packet packet-length)
@ -298,7 +305,7 @@
(define mac-byte-count (bytes-length computed-hmac-bytes))
(if (positive? mac-byte-count)
(begin
(send-bytes-credit conn mac-byte-count)
(send-packet-credit conn mac-byte-count)
(update-input-handler
#:on-data (lambda (received-hmac-bytes _mode)
(if (equal? computed-hmac-bytes received-hmac-bytes)
@ -322,9 +329,7 @@
(set! remaining-credit (- remaining-credit 1))
(issue-credit))
(update-input-handler
#:on-eof (lambda () (stop-current-facet))
#:on-data handle-packet-header)
(update-input-handler #:on-data handle-packet-header)
(at conn-ds
(when (message (inbound-credit $amount))
@ -338,8 +343,6 @@
;; Encrypted Packet Output
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (struct ssh-writer-state (config sequence-number) #:prefab)
(define (ssh-writer conn-ds conn)
(define config initial-crypto-configuration)
(define sequence-number 0)