syndicate-lang
/
syndicate-ssh
forked from syndicate-lang/marketplace-ssh-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
syndicate-ssh/new-server.rkt
View File

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

3
syndicate-ssh/ssh-host-key.rkt
View File

@ -58,9 +58,6 @@
(case host-key-alg (case host-key-alg
[(ssh-ed25519) [(ssh-ed25519)
(define signature (pk-sign private-key exchange-hash)) (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)) (bit-string (#"ssh-ed25519" :: (t:string))
(signature :: (t:string)))])) (signature :: (t:string)))]))

400
syndicate-ssh/ssh-session.rkt
View File

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

25
syndicate-ssh/ssh-transport.rkt
View File

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