forked from syndicate-lang/marketplace-ssh-2014
Channel support, and all the way up to the REPL
This commit is contained in:
parent
1b5006189b
commit
3daae80a25
|
|
@ -2,9 +2,10 @@
|
|||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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 #"")))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
version 1 .
|
||||
embeddedType EntityRef.Ref .
|
||||
|
||||
SshAuthenticatedUser = <authenticated @username bytes @service bytes>.
|
||||
|
|
@ -1,3 +1,19 @@
|
|||
version 1 .
|
||||
embeddedType EntityRef.Ref .
|
||||
|
||||
SshChannelTypeAvailable = <channel-type-available @type bytes>.
|
||||
|
||||
SshChannelRemote = <channel-remote @type bytes @extra-data bytes>.
|
||||
SshChannelLocal = <channel-local @type bytes @extra-data bytes>.
|
||||
|
||||
SshChannelOpenResponse =
|
||||
/ @ok <channel-open-confirmation @sink #!stream.Sink @extra-data bytes>
|
||||
/ @fail <channel-open-failure @sink #!stream.Sink @reason int @description bytes>
|
||||
.
|
||||
|
||||
SshChannelObject =
|
||||
/ @extended-data <channel-extended-data @type-code int>
|
||||
/ @request <channel-request @type bytes @want-reply bool>
|
||||
/ @success <channel-reply #t>
|
||||
/ @failure <channel-reply #f>
|
||||
.
|
||||
|
|
|
|||
|
|
@ -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<Uint32> 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue