forked from syndicate-lang/marketplace-ssh-2014
Push through to channel layer
This commit is contained in:
parent
5479511afa
commit
4e1d525904
|
@ -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))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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)))]))
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue