From 3daae80a25beb72ab28ad81bca1fcfedd627d96a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 19 Jun 2021 00:01:45 +0200 Subject: [PATCH] Channel support, and all the way up to the REPL --- syndicate-ssh/cook-port.rkt | 54 ++-- syndicate-ssh/new-server.rkt | 202 ++++++------- syndicate-ssh/sandboxes.rkt | 18 +- syndicate-ssh/schemas/auth.prs | 4 + syndicate-ssh/schemas/channel.prs | 16 + syndicate-ssh/ssh-session.rkt | 479 ++++++++++++------------------ 6 files changed, 335 insertions(+), 438 deletions(-) create mode 100644 syndicate-ssh/schemas/auth.prs diff --git a/syndicate-ssh/cook-port.rkt b/syndicate-ssh/cook-port.rkt index 095c00d..a9372bc 100644 --- a/syndicate-ssh/cook-port.rkt +++ b/syndicate-ssh/cook-port.rkt @@ -2,9 +2,10 @@ ;;; SPDX-License-Identifier: LGPL-3.0-or-later ;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones +(require racket/match) (require racket/port) -(provide cook-io) +(provide cook-io cook-output) (define clear-to-eol "\033[2K") (define kill-line (string-append "\r" clear-to-eol)) @@ -52,33 +53,30 @@ (lambda () (define input-buffer (make-bytes 4096)) (let loop ((b (buffer '() #f))) - (if (port-closed? cooked-in) - ;; The ultimate reader of our cooked output has closed - ;; their input port. We are therefore done. - (close-ports) - ;; TODO: remove polling for port-closed when we get port-closed-evt - (let ((count (sync/timeout 0.5 (read-bytes-avail!-evt input-buffer raw-in)))) - (cond - ((eof-object? count) ;; end-of-file on input - (close-ports)) - ((eq? count #f) ;; timeout - poll to see if cooked-out has been closed - (loop b)) - (else ;; a number - count of bytes read - (let process-bytes ((i 0) (b b)) - (if (>= i count) - (loop b) - (update-buffer b (integer->char (bytes-ref input-buffer i)) prompt - close-ports - (lambda (line new-b) - (with-handlers ((exn:fail? void)) ;; ignore write errors - (write-string "\r\n" raw-out)) - (write-string line cooked-out) - (newline cooked-out) - (process-bytes (+ i 1) new-b)) - (lambda (new-b feedback) - (with-handlers ((exn:fail? void)) ;; ignore write errors - (write-string feedback raw-out)) - (process-bytes (+ i 1) new-b)))))))))))) + (sync (handle-evt + (read-bytes-avail!-evt input-buffer raw-in) + (match-lambda + [(? eof-object?) ;; end-of-file on input + (close-ports)] + [(? number? count) + (let process-bytes ((i 0) (b b)) + (if (>= i count) + (loop b) + (update-buffer b (integer->char (bytes-ref input-buffer i)) prompt + close-ports + (lambda (line new-b) + (with-handlers ((exn:fail? void)) ;; ignore write errors + (write-string "\r\n" raw-out)) + (write-string line cooked-out) + (newline cooked-out) + (process-bytes (+ i 1) new-b)) + (lambda (new-b feedback) + (with-handlers ((exn:fail? void)) ;; ignore write errors + (write-string feedback raw-out)) + (process-bytes (+ i 1) new-b)))))])) + (handle-evt + (port-closed-evt cooked-in) + (lambda (dummy) (close-ports))))))) (values cooked-in (cook-output raw-out))) (define (cook-output raw-out) diff --git a/syndicate-ssh/new-server.rkt b/syndicate-ssh/new-server.rkt index 11df51a..999d73e 100644 --- a/syndicate-ssh/new-server.rkt +++ b/syndicate-ssh/new-server.rkt @@ -4,9 +4,12 @@ ;;; (Temporary) example client and server +(require syndicate/drivers/racket-event) (require syndicate/drivers/timer) (require syndicate/drivers/tcp) +(require syndicate/driver-support) (require syndicate/dataspace) +(require syndicate/pattern) (require (only-in racket/port peek-bytes-avail!-evt)) (require "cook-port.rkt") @@ -18,15 +21,18 @@ (require "ssh-channel.rkt") (require "ssh-message-types.rkt") (require "ssh-exceptions.rkt") +(require "schemas/gen/channel.rkt") +(require "schemas/gen/auth.rkt") (module+ main (standard-actor-system (ds) - (define spec (TcpLocal "0.0.0.0" 29418)) - (at ds - (stop-on (asserted (TcpListenError spec $message))) - (during/spawn (StreamConnection $source $sink spec) - #:name (list 'ssh source) - (session ds source sink))))) + (with-services [syndicate/drivers/racket-event] + (define spec (TcpLocal "0.0.0.0" 29418)) + (at ds + (stop-on (asserted (StreamListenerError spec $message))) + (during/spawn (StreamConnection $source $sink spec) + #:name (list 'ssh source) + (session ds source sink)))))) ;;--------------------------------------------------------------------------- @@ -86,18 +92,12 @@ ground-ds local-identification remote-identification - (lambda (user-name) - (error 'repl-boot "Would start session with ~a" user-name)) 'server))))) - ;; (at conn-ds - ;; ;; (during $m - ;; ;; (on-start (log-info "++ ~v" m)) - ;; ;; (on-stop (log-info "-- ~v" m))) - ;; (on (message $m) - ;; (log-info ">> ~v" m))) - (at conn-ds + (during (SshAuthenticatedUser $user-name #"ssh-connection") + (run-repl-instance conn-ds user-name)) + (on (asserted (protocol-error $reason-code $message _ $originated-at-peer?)) (when (not originated-at-peer?) (send! (outbound-packet (ssh-msg-disconnect reason-code @@ -109,100 +109,80 @@ ;;--------------------------------------------------------------------------- -;; ;; (repl-instance InputPort OutputPort InputPort OutputPort) -;; (struct repl-instance-state (c2s-in ;; used by thread to read input from relay -;; c2s-out ;; used by relay to feed input from remote to the thread -;; s2c-in ;; used by relay to feed output from thread to remote -;; s2c-out ;; used by thread to write output to relay -;; ) #:prefab) -;; (define (repl-instance user-name cname) -;; (define inbound-stream (channel-stream-name #t cname)) -;; (define outbound-stream (channel-stream-name #f cname)) -;; (define (ch-do action-ctor stream body) -;; (at-meta-level (action-ctor (channel-message stream body)))) -;; (define (handle-channel-message state body) -;; (match body -;; [(channel-stream-request #"pty-req" _) -;; (match-define (repl-instance-state old-in _ _ old-out) state) -;; (define-values (cooked-in cooked-out) (cook-io old-in old-out "> ")) -;; (transition (struct-copy repl-instance-state state -;; [c2s-in cooked-in] -;; [s2c-out cooked-out]) -;; (ch-do send-feedback inbound-stream (channel-stream-ok)))] -;; [(channel-stream-notify #"env" _) -;; ;; Don't care -;; (transition state)] -;; [(channel-stream-request #"shell" _) -;; (match-define (repl-instance-state c2s-in _ s2c-in s2c-out) state) -;; (define buffer-size 1024) -;; (define dummy-buffer (make-bytes buffer-size)) -;; (define repl-thread (thread (lambda () (repl-shell user-name c2s-in s2c-out)))) -;; (transition state -;; (ch-do send-feedback inbound-stream (channel-stream-ok)) -;; (subscriber (cons (thread-dead-evt repl-thread) (wild)) -;; (on-message [_ (quit #f "REPL thread exited")])) -;; (subscriber (cons (peek-bytes-avail!-evt dummy-buffer 0 #f s2c-in) (wild)) -;; ;; We're using peek-bytes-avail!-evt rather than -;; ;; read-bytes-avail!-evt because of potential overwriting -;; ;; of the buffer. The overwriting can happen when there's -;; ;; any latency between handling the event and the next -;; ;; firing of the event, since the peek-bytes-avail!-evt -;; ;; will overwrite its buffer next time it's synced on. -;; (match-state state -;; (on-message -;; [(cons _ (? eof-object?)) -;; (let () -;; (match-define (repl-instance-state c2s-in c2s-out s2c-in s2c-out) state) -;; (close-input-port c2s-in) -;; (close-output-port c2s-out) -;; (close-input-port s2c-in) -;; (close-output-port s2c-out) -;; (transition state (quit)))] -;; [(cons _ (? number? count)) -;; (transition state -;; (ch-do send-message outbound-stream (channel-stream-data -;; (read-bytes count s2c-in))))]))))] -;; [(or (channel-stream-data #"\4") ;; C-d a.k.a EOT -;; (channel-stream-eof)) -;; (let () -;; (close-output-port (repl-instance-state-c2s-out state)) -;; ;; ^ this signals the repl thread to exit. -;; ;; Now, wait for it to do so. -;; (transition state))] -;; [(channel-stream-data bs) -;; (write-bytes bs (repl-instance-state-c2s-out state)) -;; (flush-output (repl-instance-state-c2s-out state)) -;; (transition state -;; (ch-do send-feedback inbound-stream (channel-stream-credit (bytes-length bs))))] -;; [m -;; (write `(channel inbound ,m)) (newline) -;; (transition state)])) -;; (match (channel-name-type cname) -;; [#"session" -;; (define-values (c2s-in c2s-out) (make-pipe)) -;; (define-values (s2c-in s2c-out) (make-pipe)) -;; (transition (repl-instance-state c2s-in c2s-out s2c-in s2c-out) -;; (at-meta-level -;; (subscriber (channel-message inbound-stream (wild)) -;; (match-state state -;; (on-presence (transition state -;; (ch-do send-feedback inbound-stream (channel-stream-config -;; (default-packet-limit) -;; #"")) -;; (ch-do send-feedback inbound-stream (channel-stream-credit 1024)))) -;; (on-message -;; [(channel-message _ body) -;; (handle-channel-message state body)])))) -;; (at-meta-level -;; (publisher (channel-message outbound-stream (wild)) -;; (on-message [m (begin -;; (write `(channel outbound ,cname ,m)) (newline) -;; (void))]))))] -;; [type -;; (transition/no-state -;; (at-meta-level (send-message -;; (channel-message outbound-stream -;; (channel-stream-open-failure -;; SSH_OPEN_UNKNOWN_CHANNEL_TYPE -;; (bytes-append #"Unknown channel type " type))))))])) +(define (run-repl-instance conn-ds user-name) + (on-start (log-info "~s connected" user-name)) + (on-stop (log-info "~s disconnected" user-name)) + + (at conn-ds + (assert (SshChannelTypeAvailable #"session")) + (during (StreamConnection $source $sink (SshChannelLocal #"session" _)) + ;; c2s-in used by repl to read input from channel + ;; c2s-out used by channel to feed input from remote to the repl + ;; s2c-in used by channel to feed output from repl to remote + ;; s2c-out used by repl to write output to channel + (define-values (c2s-in c2s-out) (make-pipe)) + (define-values (s2c-in s2c-out) (make-pipe)) + (define-values (s2c-err-in s2c-err-out) (make-pipe)) + (on-stop (close-input-port c2s-in) + (close-output-port c2s-out) + (close-input-port s2c-in) + (close-output-port s2c-out) + (close-input-port s2c-err-in) + (close-output-port s2c-err-out)) + + (define (handle-data data mode) + (match mode + [(Mode-bytes) + (write-bytes data c2s-out) + (flush-output c2s-out) + (send-bytes-credit source (bytes-length data))] + [(Mode-object (:parse (SshChannelObject-extended-data type-code))) + (match type-code + [SSH_EXTENDED_DATA_STDERR + (log-info "2> ~s" data)] + [_ + (log-warning "Ignoring extended data type-code ~s: ~s" type-code data)]) + (send-bytes-credit source (bytes-length data))] + [(Mode-object (:parse (SshChannelObject-request type want-reply))) + (define ok? (handle-request type)) + (when want-reply + (define reply (if ok? (SshChannelObject-success) (SshChannelObject-failure))) + (send-data sink #"" (Mode-object reply)))])) + + (define (handle-eof) + (close-output-port c2s-out)) + + (define (handle-request type) + (match type + [#"pty-req" + (define-values (cooked-c2s-in cooked-s2c-out) (cook-io c2s-in s2c-out "> ")) + (set! c2s-in cooked-c2s-in) + (set! s2c-out cooked-s2c-out) + (set! s2c-err-out (cook-output s2c-err-out)) + #t] + [#"env" + ;; Don't care + ;; TODO: care? + #t] + [#"shell" + (make-sink #:initial-source (port-source s2c-in) + #:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes))) + #:on-data (lambda (data _mode) (send-data sink data)) + #:on-eof (lambda () (stop-current-facet))) + (make-sink #:initial-source (port-source s2c-err-in) + #:on-connect (lambda (s) (send-credit s (CreditAmount-unbounded) (Mode-bytes))) + #:on-data (lambda (data _mode) + (send-data sink data + (Mode-object (SshChannelObject-extended-data + SSH_EXTENDED_DATA_STDERR))))) + (linked-thread #:name 'repl + (lambda (_facet) + (repl-shell user-name c2s-in s2c-out s2c-err-out))) + #t] + [_ + (log-warning "Unsupported channel request type ~s" type) + #f])) + + (handle-connection source sink #:initial-credit #f #:on-data handle-data #:on-eof handle-eof) + (assert (SshChannelOpenResponse-ok sink #""))))) diff --git a/syndicate-ssh/sandboxes.rkt b/syndicate-ssh/sandboxes.rkt index 5c1c6ee..42c4c87 100644 --- a/syndicate-ssh/sandboxes.rkt +++ b/syndicate-ssh/sandboxes.rkt @@ -6,6 +6,7 @@ (require racket/match) (require racket/sandbox) +(require (only-in racket/exn exn->string)) (provide repl-shell) @@ -23,14 +24,14 @@ ns)))) (hash-ref *user-states* username)) -(define (repl-shell username in out) +(define (repl-shell username in out [err out]) (match-define (user-state _ primary-sandbox primary-namespace) (get-user-state username)) (parameterize ((current-input-port in) (current-output-port out) - (current-error-port out) + (current-error-port err) (sandbox-input in) (sandbox-output out) - (sandbox-error-output out) + (sandbox-error-output err) (sandbox-memory-limit 2) ;; megabytes (sandbox-eval-limits #f) (sandbox-namespace-specs (list (lambda () primary-namespace)))) @@ -39,8 +40,15 @@ ;; ^^ uses primary-namespace via sandbox-namespace-specs (parameterize ((current-namespace primary-namespace) (current-eval secondary-sandbox)) - (read-eval-print-loop)) + (let restart () + (with-handlers ([exn? + (lambda (e) + (fprintf err "~a" (exn->string e)) + (flush-output err) + (restart))]) + (read-eval-print-loop)))) (fprintf out "\nGoodbye!\n") (kill-evaluator secondary-sandbox) (close-input-port in) - (close-output-port out))) + (close-output-port out) + (close-output-port err))) diff --git a/syndicate-ssh/schemas/auth.prs b/syndicate-ssh/schemas/auth.prs new file mode 100644 index 0000000..58605c4 --- /dev/null +++ b/syndicate-ssh/schemas/auth.prs @@ -0,0 +1,4 @@ +version 1 . +embeddedType EntityRef.Ref . + +SshAuthenticatedUser = . diff --git a/syndicate-ssh/schemas/channel.prs b/syndicate-ssh/schemas/channel.prs index 8a426f1..ae5a618 100644 --- a/syndicate-ssh/schemas/channel.prs +++ b/syndicate-ssh/schemas/channel.prs @@ -1,3 +1,19 @@ version 1 . embeddedType EntityRef.Ref . +SshChannelTypeAvailable = . + +SshChannelRemote = . +SshChannelLocal = . + +SshChannelOpenResponse = + / @ok + / @fail +. + +SshChannelObject = + / @extended-data + / @request + / @success + / @failure +. diff --git a/syndicate-ssh/ssh-session.rkt b/syndicate-ssh/ssh-session.rkt index f81ce8e..c0bc3a0 100644 --- a/syndicate-ssh/ssh-session.rkt +++ b/syndicate-ssh/ssh-session.rkt @@ -4,6 +4,8 @@ (require bitsyntax) (require syndicate/drivers/timer) +(require syndicate/drivers/stream) +(require syndicate/pattern) (require "crypto.rkt") (require "oakley-groups.rkt") @@ -13,6 +15,8 @@ (require "ssh-exceptions.rkt") (require "ssh-transport.rkt") (require "ssh-channel.rkt") +(require "schemas/gen/channel.rkt") +(require "schemas/gen/auth.rkt") (provide rekey-interval rekey-volume @@ -36,12 +40,11 @@ ;; An AuthenticationState is one of ;; - #f, for not-yet-authenticated -;; - an (authenticated String String), recording successful completion +;; - an (SshAuthenticatedUser Bytes Bytes), recording successful completion ;; of the authentication protocol after a request to be identified ;; as the given username for the given service. ;; TODO: When authentication is properly implemented, we will need ;; intermediate states here too. -(struct authenticated (username service) #:prefab) ;; Generic inputs into the exchange-hash part of key ;; exchange. Diffie-Hellman uses these fields along with the host key, @@ -71,18 +74,18 @@ (define-syntax with-incoming-task (syntax-rules () - [(_ (seq-id type-byte packet-pattern message-pattern) body ...) - (with-incoming-task* on (seq-id type-byte packet-pattern message-pattern) body ...)])) + [(_ (type-byte packet-pattern message-pattern) body ...) + (with-incoming-task* on (type-byte packet-pattern message-pattern) body ...)])) (define-syntax-rule - (with-incoming-task/react (seq-id type-byte packet-pattern message-pattern) body ...) + (with-incoming-task/react (type-byte packet-pattern message-pattern) body ...) (react - (with-incoming-task* stop-on (seq-id type-byte packet-pattern message-pattern) + (with-incoming-task* stop-on (type-byte packet-pattern message-pattern) body ...))) (define-syntax with-incoming-task* (syntax-rules () - [(_ on-stx (seq-id type-byte packet-pattern message-pattern) body ...) + [(_ on-stx (type-byte packet-pattern message-pattern) body ...) (on-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern)) body ... (send! (task-complete seq-id)))])) @@ -150,7 +153,7 @@ (match-define (list 'dh 'public p g public-key-as-integer) (pk-key->datum private-key 'rkt-public)) (at conn-ds - (with-incoming-task/react (seq SSH_MSG_KEXDH_INIT _ (ssh-msg-kexdh-init $e)) + (with-incoming-task/react (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) @@ -182,8 +185,8 @@ (pk-key->datum private-key 'rkt-public)) (at conn-ds (send! (outbound-packet (ssh-msg-kexdh-init public-key-as-integer))) - (with-incoming-task/react (seq SSH_MSG_KEXDH_REPLY _ - (ssh-msg-kexdh-reply $host-key-bytes $f $h-signature)) + (with-incoming-task/react + (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) @@ -290,7 +293,7 @@ (bit-string (k-h-prefix :: binary) (key :: binary)))))))))) (at conn-ds - (with-incoming-task/react (seq SSH_MSG_NEWKEYS _ (ssh-msg-newkeys)) + (with-incoming-task/react (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. @@ -314,11 +317,12 @@ (define (service-request-handler conn-ds) (define-field authentication-state #f) + (begin/dataflow (log-info "authentication-state ~s" (authentication-state))) (at conn-ds (assert #:when (authentication-state) (authentication-state)) - (with-incoming-task (seq SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service)) + (with-incoming-task (SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service)) (match service [#"ssh-userauth" (cond @@ -329,20 +333,18 @@ (at conn-ds (send! (outbound-packet (ssh-msg-service-accept service))) (with-incoming-task/react - (seq SSH_MSG_USERAUTH_REQUEST _ - (ssh-msg-userauth-request $user-name $service-name _ _)) + (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! (outbound-packet (ssh-msg-userauth-success))) - (authentication-state (authenticated user-name service-name)) + (authentication-state (SshAuthenticatedUser user-name service-name)) (react - (with-incoming-task (seq SSH_MSG_USERAUTH_REQUEST _ _) + (with-incoming-task (SSH_MSG_USERAUTH_REQUEST _ _) ;; RFC4252 section 5.1 page 6 )) - (let ((a (authentication-state))) - (spawn #:name 'connection-service (start-connection-service conn-ds a)))] + (spawn #:name 'channel-manager (run-channel-manager conn-ds))] [else (send! (outbound-packet (ssh-msg-userauth-failure '(none) #f)))])))])] [_ @@ -354,206 +356,172 @@ ;; Channel management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (define (unused-local-channel-ref conn) -;; (define (bump-candidate candidate) -;; (modulo (+ candidate 1) #x100000000)) -;; (define first-candidate (match (connection-channels conn) -;; ['() 0] -;; [(cons ch _) (bump-candidate (ssh-channel-local-ref ch))])) -;; (let examine-candidate ((candidate first-candidate)) -;; (let loop ((chs (connection-channels conn))) -;; (cond -;; [(null? chs) candidate] -;; [(= (ssh-channel-local-ref (car chs)) candidate) -;; (examine-candidate (bump-candidate candidate))] -;; [else (loop (cdr chs))])))) +(define (run-inbound-channel conn-ds + #:type channel-type + #:remote-ref remote-ref + #:local-ref local-ref + #:initial-window-size initial-window-size + #:maximum-packet-size maximum-packet-size + #:extra-request-data extra-request-data) + (define (! message) (send! conn-ds (outbound-packet message))) -;; (define (replacef proc updater creator lst) -;; (let loop ((lst lst)) -;; (cond [(null? lst) (list (creator))] -;; [(proc (car lst)) (cons (updater (car lst)) (cdr lst))] -;; [else (cons (car lst) (loop (cdr lst)))]))) + (log-info "Starting channel, type ~s" channel-type) + (on-stop (log-info "Stopping channel, type ~s" channel-type)) -;; (define (remf proc lst) -;; (cond [(null? lst) '()] -;; [(proc (car lst)) (cdr lst)] -;; [else (cons (car lst) (remf proc (cdr lst)))])) + (define (on-connect source sink) + (at conn-ds + (stop-on (message (task _ SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close local-ref)))) -;; ;; ChannelName -> ChannelState -> Boolean -;; (define ((ssh-channel-name=? cname) c) -;; (equal? (ssh-channel-name c) cname)) + (with-incoming-task + (SSH_MSG_CHANNEL_WINDOW_ADJUST _ (ssh-msg-channel-window-adjust local-ref $n)) + (send-bytes-credit source n)) -;; ;; Connection Uint32 -> ChannelState -;; (define (get-channel conn local-ref) -;; (define ch (findf (lambda (c) (equal? (ssh-channel-local-ref c) local-ref)) -;; (connection-channels conn))) -;; (when (not ch) -;; (disconnect-with-error SSH_DISCONNECT_PROTOCOL_ERROR -;; "Attempt to use known channel local-ref ~v" -;; local-ref)) -;; ch) + (with-incoming-task (SSH_MSG_CHANNEL_DATA _ (ssh-msg-channel-data local-ref $data)) + (send-data sink data)) -;; ;; ChannelName Maybe Connection -> Connection -;; (define (update-channel cname updater conn) -;; (struct-copy connection conn -;; [channels -;; (replacef (ssh-channel-name=? cname) -;; updater -;; (lambda () (updater (ssh-channel cname -;; (unused-local-channel-ref conn) -;; #f -;; #f -;; 'neither))) -;; (connection-channels conn))])) + (with-incoming-task + (SSH_MSG_CHANNEL_EXTENDED_DATA _ (ssh-msg-channel-extended-data local-ref $type-code $data)) + (send-data sink data (Mode-object (SshChannelObject-extended-data type-code)))) -;; ;; ChannelName Connection -> Connection -;; (define (discard-channel cname conn) -;; (struct-copy connection conn -;; [channels -;; (remf (ssh-channel-name=? cname) (connection-channels conn))])) + (with-incoming-task (SSH_MSG_CHANNEL_EOF _ (ssh-msg-channel-eof local-ref)) + (send-eof sink)) -;; ;; 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))) + (with-incoming-task + (SSH_MSG_CHANNEL_REQUEST _ (ssh-msg-channel-request local-ref $type $want-reply? $data)) + (send-data sink data (Mode-object (SshChannelObject-request type want-reply?)))) -;; (define (maybe-close-channel cname conn action) -;; (cond -;; [(findf (ssh-channel-name=? cname) (connection-channels conn)) => -;; (lambda (ch) -;; (define old-close-state (ssh-channel-close-state ch)) -;; (define new-close-state (update-close-state old-close-state action)) -;; (transition (if (eq? new-close-state 'both) -;; (discard-channel ch conn) -;; (update-channel cname -;; (lambda (ch) -;; (struct-copy ssh-channel ch -;; [close-state new-close-state])) -;; conn)) -;; (case action -;; [(local) -;; (case old-close-state -;; [(neither remote) -;; (list (send-message (outbound-packet -;; (ssh-msg-channel-close (ssh-channel-remote-ref ch)))))] -;; [else (list)])] -;; [(remote) -;; (case old-close-state -;; [(neither local) -;; (list (delete-endpoint (list cname 'outbound)) -;; (delete-endpoint (list cname 'inbound)))] -;; [else (list)])])))] -;; [else (transition conn)])) + (with-incoming-task + (SSH_MSG_CHANNEL_SUCCESS _ (ssh-msg-channel-success local-ref)) + (send-data sink #"" (Mode-object (SshChannelObject-success)))) -;; (define (channel-endpoints cname initial-message-producer) -;; (define inbound-stream-name (channel-stream-name #t cname)) -;; (define outbound-stream-name (channel-stream-name #f cname)) -;; (define (! conn message) -;; (transition conn (send-message (outbound-packet message)))) -;; (list -;; (name-endpoint (list cname 'outbound) -;; (subscriber (channel-message outbound-stream-name (wild)) -;; (match-state conn -;; (on-presence (transition conn -;; (initial-message-producer inbound-stream-name outbound-stream-name))) -;; (on-absence (maybe-close-channel cname conn 'local)) -;; (on-message -;; [(channel-message _ body) -;; (let () -;; (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) -;; (define remote-ref (ssh-channel-remote-ref ch)) -;; (match body -;; [(channel-stream-data data-bytes) -;; ;; TODO: split data-bytes into packets if longer than max packet size -;; (! conn (ssh-msg-channel-data remote-ref data-bytes))] -;; [(channel-stream-extended-data type data-bytes) -;; (! conn (ssh-msg-channel-extended-data remote-ref type data-bytes))] -;; [(channel-stream-eof) -;; (! conn (ssh-msg-channel-eof remote-ref))] -;; [(channel-stream-notify type data-bytes) -;; (! conn (ssh-msg-channel-request remote-ref type #f data-bytes))] -;; [(channel-stream-request type data-bytes) -;; (! conn (ssh-msg-channel-request remote-ref type #t data-bytes))] -;; [(channel-stream-open-failure reason description) -;; (! (discard-channel cname conn) -;; (ssh-msg-channel-open-failure remote-ref reason description #""))]))])))) -;; (name-endpoint (list cname 'inbound) -;; (publisher (channel-message inbound-stream-name (wild)) -;; (match-state conn -;; (on-message -;; [(channel-message _ body) -;; (let () -;; (define ch (findf (ssh-channel-name=? cname) (connection-channels conn))) -;; (define remote-ref (ssh-channel-remote-ref ch)) -;; (match body -;; [(channel-stream-config maximum-packet-size extra-data) -;; (if (channel-name-locally-originated? cname) -;; ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN. -;; (! conn (ssh-msg-channel-open (channel-name-type cname) -;; (ssh-channel-local-ref ch) -;; 0 -;; maximum-packet-size -;; extra-data)) -;; ;; This must be intended to form the SSH_MSG_CHANNEL_OPEN_CONFIRMATION. -;; (! conn (ssh-msg-channel-open-confirmation remote-ref -;; (ssh-channel-local-ref ch) -;; 0 -;; maximum-packet-size -;; extra-data)))] -;; [(channel-stream-credit count) -;; (! conn (ssh-msg-channel-window-adjust remote-ref count))] -;; [(channel-stream-ok) -;; (! conn (ssh-msg-channel-success remote-ref))] -;; [(channel-stream-fail) -;; (! conn (ssh-msg-channel-failure remote-ref))]))])))))) + (with-incoming-task + (SSH_MSG_CHANNEL_FAILURE _ (ssh-msg-channel-failure local-ref)) + (send-data sink #"" (Mode-object (SshChannelObject-failure)))) -;; (define (channel-notify conn ch inbound? body) -;; (transition conn -;; (send-message (channel-message (channel-stream-name inbound? (ssh-channel-name ch)) -;; body) -;; (if inbound? 'publisher 'subscriber)))) + (once + [(asserted (SshChannelOpenResponse-ok remote-sink $extra-data)) + (! (ssh-msg-channel-open-confirmation remote-ref + local-ref + 1048576 ;; TODO + 16384 ;; TODO + extra-data))] + [(asserted (SshChannelOpenResponse-fail remote-sink $reason $description)) + (! (ssh-msg-channel-open-failure remote-ref + reason + description + #"")) + (stop-current-facet)]))) + + (match-define + (list remote-source remote-sink) + (establish-connection conn-ds (SshChannelLocal channel-type extra-request-data) + #:name (list 'R remote-ref 'L local-ref) + #:on-connect on-connect + #:on-rejected + (lambda (message) + (! (ssh-msg-channel-open-failure remote-ref + SSH_OPEN_ADMINISTRATIVELY_PROHIBITED + (string->bytes/utf-8 message) + #"")) + (stop-current-facet)) + #:on-disconnect (lambda () (stop-current-facet)) + #:on-error (lambda (message) (stop-current-facet)) + #:on-credit + (lambda (amount mode) + (match-define (Mode-bytes) mode) + (match-define (CreditAmount-count n) amount) + (! (ssh-msg-channel-window-adjust remote-ref n))) + #:initial-credit (CreditAmount-count initial-window-size) + #:initial-mode (Mode-bytes) + #:on-data + (lambda (data mode) + (match mode + [(Mode-bytes) + (! (ssh-msg-channel-data remote-ref data))] + [(Mode-lines (LineMode-lf)) + (! (ssh-msg-channel-data remote-ref (bytes-append data "\n")))] + [(Mode-lines (LineMode-crlf)) + (! (ssh-msg-channel-data remote-ref (bytes-append data "\r\n")))] + [(Mode-object (:parse (SshChannelObject-extended-data type-code))) + (! (ssh-msg-channel-extended-data remote-ref type-code data))] + [(Mode-object (:parse (SshChannelObject-request type want-reply))) + (! (ssh-msg-channel-request remote-ref type want-reply data))] + [(Mode-object (:parse (SshChannelObject-success))) + (! (ssh-msg-channel-success remote-ref))] + [(Mode-object (:parse (SshChannelObject-failure))) + (! (ssh-msg-channel-failure remote-ref))])) + #:on-eof (lambda () + (! (ssh-msg-channel-eof remote-ref))))) + (void)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Connection service +;; Channel manager ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (define (respond-to-opened-outbound-channel conn cname) -;; (if (and (ground? cname) -;; (not (memf (ssh-channel-name=? cname) (connection-channels conn)))) -;; (transition (update-channel cname values conn) -;; (channel-endpoints cname (lambda (inbound-stream outbound-stream) -;; '()))) -;; (transition conn))) +(define (run-channel-manager conn-ds) + (define local-refs-by-remote-ref (make-hash)) + (define remote-refs-by-local-ref (make-hash)) -(define (start-connection-service conn-ds authentication) - (match-define (authenticated user-name _service-name) authentication) + (define (allocate-local-ref remote-ref) + (when (hash-has-key? local-refs-by-remote-ref remote-ref) + (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR + "Attempt to reuse remote-ref ~a" + remote-ref)) + (for/or ([i (in-range 0 32)]) ;; TODO: this is an arbitrary limit + (if (hash-has-key? remote-refs-by-local-ref i) + #f + (begin (hash-set! remote-refs-by-local-ref i remote-ref) + (hash-set! local-refs-by-remote-ref remote-ref i) + i)))) - (handle-msg-channel-open conn-ds) + (at conn-ds - ;; (set-handlers conn - ;; ;; TODO: SSH_MSG_GLOBAL_REQUEST handle-msg-global-request - ;; SSH_MSG_CHANNEL_OPEN handle-msg-channel-open - ;; SSH_MSG_CHANNEL_OPEN_CONFIRMATION handle-msg-channel-open-confirmation - ;; SSH_MSG_CHANNEL_OPEN_FAILURE handle-msg-channel-open-failure - ;; SSH_MSG_CHANNEL_WINDOW_ADJUST handle-msg-channel-window-adjust - ;; SSH_MSG_CHANNEL_DATA handle-msg-channel-data - ;; SSH_MSG_CHANNEL_EXTENDED_DATA handle-msg-channel-extended-data - ;; SSH_MSG_CHANNEL_EOF handle-msg-channel-eof - ;; SSH_MSG_CHANNEL_CLOSE handle-msg-channel-close - ;; SSH_MSG_CHANNEL_REQUEST handle-msg-channel-request - ;; SSH_MSG_CHANNEL_SUCCESS handle-msg-channel-success - ;; SSH_MSG_CHANNEL_FAILURE handle-msg-channel-failure)) + (with-incoming-task (SSH_MSG_CHANNEL_CLOSE _ (ssh-msg-channel-close $local-ref)) + (when (not (hash-has-key? remote-refs-by-local-ref local-ref)) + (disconnect-with-error conn-ds + SSH_DISCONNECT_PROTOCOL_ERROR + "Received channel close for non-open channel ~a" + local-ref)) + (hash-remove! remote-refs-by-local-ref local-ref)) + + (with-incoming-task (SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type + $remote-ref + $initial-window-size + $maximum-packet-size + $extra-request-data)) + (log-info "open ~s" (list channel-type remote-ref initial-window-size maximum-packet-size extra-request-data)) + (with-assertion-presence conn-ds (SshChannelTypeAvailable channel-type) + #:on-present [(define local-ref (allocate-local-ref remote-ref)) + (if (not local-ref) + (send! (outbound-packet + (ssh-msg-channel-open-failure remote-ref + SSH_OPEN_RESOURCE_SHORTAGE + #"Too many open channels" + #""))) + (react + (on-stop (log-info "Releasing channel assignment ~s" + (list 'R remote-ref 'L local-ref)) + (send! (outbound-packet (ssh-msg-channel-close remote-ref))) + (hash-remove! local-refs-by-remote-ref remote-ref)) + (spawn/link + #:name (list 'R remote-ref 'L local-ref) + (run-inbound-channel conn-ds + #:type channel-type + #:remote-ref remote-ref + #:local-ref local-ref + #:initial-window-size initial-window-size + #:maximum-packet-size maximum-packet-size + #:extra-request-data extra-request-data))))] + #:on-absent [(send! (outbound-packet + (ssh-msg-channel-open-failure remote-ref + SSH_OPEN_UNKNOWN_CHANNEL_TYPE + #"Unknown channel type" + #"")))]))) + + ;; 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. - ;; (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) _) @@ -562,45 +530,10 @@ ;; (match-state conn ;; (match-conversation (channel-message (channel-stream-name #f cname) _) ;; (on-presence (respond-to-opened-outbound-channel conn cname))))) - (void) + ) -(define (handle-msg-channel-open conn-ds) - (void) - ;; (at conn-ds - ;; (with-incoming-task (seq SSH_MSG_CHANNEL_OPEN _ (ssh-msg-channel-open $channel-type - ;; $remote-ref - ;; $initial-window-size - ;; $maximum-packet-size - ;; $extra-request-data)) - ;; ( - ;; (react - ;; (on (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 @@ -638,50 +571,6 @@ ;; (channel-stream-open-failure reason description))) ;; (lambda (conn) (maybe-close-channel (ssh-channel-name ch) conn 'remote)))) -;; (define (handle-msg-channel-window-adjust packet message conn) -;; (match-define (ssh-msg-channel-window-adjust local-ref count) message) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #f (channel-stream-credit count))) - -;; (define (handle-msg-channel-data packet message conn) -;; (match-define (ssh-msg-channel-data local-ref data*) message) -;; (define data (bit-string->bytes data*)) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #t (channel-stream-data data))) - -;; (define (handle-msg-channel-extended-data packet message conn) -;; (match-define (ssh-msg-channel-extended-data local-ref type-code data*) message) -;; (define data (bit-string->bytes data*)) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #t (channel-stream-extended-data type-code data))) - -;; (define (handle-msg-channel-eof packet message conn) -;; (define ch (get-channel conn (ssh-msg-channel-eof-recipient-channel message))) -;; (channel-notify conn ch #t (channel-stream-eof))) - -;; (define (handle-msg-channel-close packet message conn) -;; (define ch (get-channel conn (ssh-msg-channel-close-recipient-channel message))) -;; (maybe-close-channel (ssh-channel-name ch) conn 'remote)) - -;; (define (handle-msg-channel-request packet message conn) -;; (match-define (ssh-msg-channel-request local-ref type* want-reply? data*) message) -;; (define type (bit-string->bytes type*)) -;; (define data (bit-string->bytes data*)) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #t -;; (if want-reply? -;; (channel-stream-request type data) -;; (channel-stream-notify type data)))) - -;; (define (handle-msg-channel-success packet message conn) -;; (match-define (ssh-msg-channel-success local-ref) message) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #f (channel-stream-ok))) - -;; (define (handle-msg-channel-failure packet message conn) -;; (match-define (ssh-msg-channel-failure local-ref) message) -;; (define ch (get-channel conn local-ref)) -;; (channel-notify conn ch #f (channel-stream-fail))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Session main process @@ -691,7 +580,6 @@ ground-ds local-identification-string peer-identification-string - application-boot session-role) (define-field rekey-state (rekey-in-seconds-or-bytes -1 -1 0)) (define-field session-id #f) @@ -701,29 +589,32 @@ (define channels '()) (at conn-ds - (with-incoming-task (seq SSH_MSG_DISCONNECT _ - (ssh-msg-disconnect $reason-code $description $language-tag)) - (disconnect-with-error* conn-ds #t - '() - reason-code - "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" - reason-code - (bytes->string/utf-8 (bit-string->bytes description)))) + (with-incoming-task + (SSH_MSG_DISCONNECT _ (ssh-msg-disconnect $reason-code $description $language-tag)) + (if (= reason-code SSH_DISCONNECT_BY_APPLICATION) + (begin (log-debug "Received SSH_DISCONNECT_BY_APPLICATION") + (assert (protocol-error reason-code description '() #t))) + (disconnect-with-error* conn-ds #t + '() + reason-code + "Received SSH_MSG_DISCONNECT with reason code ~a and message ~s" + reason-code + (bytes->string/utf-8 (bit-string->bytes description))))) - (with-incoming-task (seq SSH_MSG_IGNORE _ (ssh-msg-ignore _))) + (with-incoming-task (SSH_MSG_IGNORE _ (ssh-msg-ignore _))) - (with-incoming-task (seq SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq)) + (with-incoming-task (SSH_MSG_UNIMPLEMENTED _ (ssh-msg-unimplemented $peer-seq)) (disconnect-with-error/local-info conn-ds `((offending-sequence-number ,peer-seq)) SSH_DISCONNECT_PROTOCOL_ERROR "Disconnecting because of received SSH_MSG_UNIMPLEMENTED.")) - (with-incoming-task (seq SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _))) + (with-incoming-task (SSH_MSG_DEBUG _ ($ message (ssh-msg-debug _ _ _))) (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message))) - (with-incoming-task (seq SSH_MSG_KEXINIT $packet - ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))) + (with-incoming-task + (SSH_MSG_KEXINIT $packet ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _))) (do-kexinit conn-ds ground-ds #:packet packet