2021-06-12 18:31:34 +00:00
|
|
|
#lang syndicate
|
2021-06-10 20:01:36 +00:00
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
|
|
|
|
;;; (Temporary) example client and server
|
2013-05-10 21:01:46 +00:00
|
|
|
|
2021-06-12 18:31:34 +00:00
|
|
|
(require syndicate/drivers/timer)
|
|
|
|
(require syndicate/drivers/tcp)
|
|
|
|
(require syndicate/dataspace)
|
|
|
|
|
2013-05-10 21:01:46 +00:00
|
|
|
(require (only-in racket/port peek-bytes-avail!-evt))
|
|
|
|
(require "cook-port.rkt")
|
|
|
|
(require "sandboxes.rkt")
|
|
|
|
|
|
|
|
(require "ssh-numbers.rkt")
|
|
|
|
(require "ssh-transport.rkt")
|
|
|
|
(require "ssh-session.rkt")
|
|
|
|
(require "ssh-channel.rkt")
|
|
|
|
(require "ssh-message-types.rkt")
|
|
|
|
(require "ssh-exceptions.rkt")
|
|
|
|
|
2021-06-12 18:31:34 +00:00
|
|
|
(module+ main
|
2021-06-17 13:57:55 +00:00
|
|
|
(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)))))
|
2013-05-10 21:01:46 +00:00
|
|
|
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
|
|
|
(define (check-remote-identification! peer-identification-string)
|
|
|
|
(define required-peer-identification-regex #rx"^SSH-2\\.0-.*")
|
|
|
|
;; Each identification string is both a cleartext indicator that
|
|
|
|
;; we've reached some notion of the right place and also input to
|
|
|
|
;; the hash function used during D-H key exchange.
|
|
|
|
(when (not (regexp-match required-peer-identification-regex
|
|
|
|
peer-identification-string))
|
|
|
|
(error 'ssh-session
|
|
|
|
"Invalid peer identification string ~v"
|
|
|
|
peer-identification-string)))
|
|
|
|
|
2021-06-16 19:57:17 +00:00
|
|
|
(define (session ground-ds source sink)
|
2021-06-14 15:09:35 +00:00
|
|
|
(define local-identification #"SSH-2.0-RacketSSH_0.0")
|
2021-06-15 12:52:21 +00:00
|
|
|
|
|
|
|
(define id-line-reader-facet
|
|
|
|
(react
|
2021-06-16 19:57:17 +00:00
|
|
|
(on-start (send-line sink local-identification)
|
|
|
|
(send-lines-credit source 1 (LineMode-crlf)))
|
|
|
|
(handle-connection source sink
|
2021-06-15 12:52:21 +00:00
|
|
|
#:initial-credit #f
|
|
|
|
#:on-data (lambda (remote-identification _mode)
|
|
|
|
(check-remote-identification! remote-identification)
|
|
|
|
(send! session-vm-factory remote-identification)))))
|
|
|
|
|
2021-06-16 19:57:17 +00:00
|
|
|
(define transfers-remaining 2)
|
2021-06-15 12:52:21 +00:00
|
|
|
(define transfer-control
|
|
|
|
(object #:name 'transfer-control
|
2021-06-16 19:57:17 +00:00
|
|
|
[#:message 'transfer-control
|
|
|
|
(set! transfers-remaining (- transfers-remaining 1))
|
|
|
|
(when (zero? transfers-remaining) (stop-facet id-line-reader-facet))]))
|
2021-06-15 12:52:21 +00:00
|
|
|
|
|
|
|
(define session-vm-factory
|
|
|
|
(object
|
|
|
|
#:name 'session-vm-factory
|
|
|
|
[#:message remote-identification
|
2021-06-16 19:57:17 +00:00
|
|
|
(on-stop (log-info "Session VM for ~a closed" source))
|
2021-06-15 12:52:21 +00:00
|
|
|
(actor-group
|
|
|
|
#:link? #t
|
|
|
|
(define conn-ds (dataspace #:name (gensym 'conn-ds)))
|
|
|
|
|
2021-06-16 19:57:17 +00:00
|
|
|
(spawn #:name 'reader (ssh-reader conn-ds source transfer-control))
|
|
|
|
(spawn #:name 'writer (ssh-writer conn-ds sink transfer-control))
|
2021-06-15 12:52:21 +00:00
|
|
|
|
|
|
|
;; Wait for the reader and writer get started, then tell the reader
|
|
|
|
;; we are ready for a single packet and spawn the session manager.
|
|
|
|
(react
|
|
|
|
(at conn-ds
|
2021-06-17 13:57:55 +00:00
|
|
|
(stop-on (asserted (Observe (:pattern (inbound-credit ,_)) _))
|
|
|
|
(send! (inbound-credit 1))
|
2021-06-15 12:52:21 +00:00
|
|
|
|
|
|
|
(spawn
|
|
|
|
#:name 'session
|
|
|
|
(ssh-session conn-ds
|
|
|
|
ground-ds
|
|
|
|
local-identification
|
|
|
|
remote-identification
|
|
|
|
(lambda (user-name)
|
|
|
|
(error 'repl-boot "Would start session with ~a" user-name))
|
|
|
|
'server)))))
|
|
|
|
|
|
|
|
;; (at conn-ds
|
|
|
|
;; ;; (during $m
|
|
|
|
;; ;; (on-start (log-info "++ ~v" m))
|
|
|
|
;; ;; (on-stop (log-info "-- ~v" m)))
|
2021-06-17 13:57:55 +00:00
|
|
|
;; (on (message $m)
|
2021-06-15 12:52:21 +00:00
|
|
|
;; (log-info ">> ~v" m)))
|
|
|
|
|
|
|
|
(at conn-ds
|
2021-06-17 13:57:55 +00:00
|
|
|
(on (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
|
2021-06-15 12:52:21 +00:00
|
|
|
(when (not originated-at-peer?)
|
2021-06-17 13:57:55 +00:00
|
|
|
(send! (outbound-packet (ssh-msg-disconnect reason-code
|
|
|
|
(string->bytes/utf-8 message)
|
|
|
|
#""))))
|
2021-06-15 12:52:21 +00:00
|
|
|
(sync! conn-ds (stop-actor-system)))))]))
|
|
|
|
|
|
|
|
(void))
|
2013-05-10 21:01:46 +00:00
|
|
|
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
|
2021-06-12 18:31:34 +00:00
|
|
|
;; ;; (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))))))]))
|