syndicate-ssh/syndicate-ssh/new-server.rkt

#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

;;; (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")
(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")
(require "schemas/gen/channel.rkt")
(require "schemas/gen/auth.rkt")

(module+ main
  (standard-actor-system (ds)
    (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))))))

;;---------------------------------------------------------------------------

(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)))

(define (session ground-ds source sink)
  (define local-identification #"SSH-2.0-RacketSSH_0.0")

  (define id-line-reader-facet
    (react
      (on-start (send-line sink local-identification)
                (send-lines-credit source 1 (LineMode-crlf)))
      (handle-connection source sink
                         #:initial-credit #f
                         #:on-data (lambda (remote-identification _mode)
                                     (check-remote-identification! remote-identification)
                                     (send! session-vm-factory remote-identification)))))

  (define transfers-remaining 2)
  (define transfer-control
    (object #:name 'transfer-control
            [#:message 'transfer-control
             (set! transfers-remaining (- transfers-remaining 1))
             (when (zero? transfers-remaining) (stop-facet id-line-reader-facet))]))

  (define session-vm-factory
    (object
      #:name 'session-vm-factory
      [#:message remote-identification
       (on-stop (log-info "Session VM for ~a closed" source))
       (actor-group
         #:link? #t
         (define conn-ds (dataspace #:name (gensym 'conn-ds)))

         (spawn #:name 'reader (ssh-reader conn-ds source transfer-control))
         (spawn #:name 'writer (ssh-writer conn-ds sink transfer-control))

         ;; Wait for the reader and writer get started, then tell the reader
         ;; we are ready for a single packet and spawn the session manager.
         (react
           (at conn-ds
             (stop-on (asserted (Observe (:pattern (inbound-credit ,_)) _))
               (send! (inbound-credit 1))

               (spawn
                 #:name 'session
                 (ssh-session conn-ds
                              ground-ds
                              local-identification
                              remote-identification
                              'server)))))

         (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
                                                           (string->bytes/utf-8 message)
                                                           #""))))
             (sync! conn-ds (stop-actor-system)))))]))

  (void))

;;---------------------------------------------------------------------------


(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 #"")))))