#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 (session ground-ds source sink)
  (on-stop (log-info "Session VM for ~a closed" source))
  (actor-group
    #:link? #t
    (define conn-ds (dataspace #:name (gensym 'conn-ds)))

    (define local-identification #"SSH-2.0-RacketSSH_0.0")

    (spawn/link #:name 'reader (ssh-reader conn-ds ground-ds source))
    (spawn/link #:name 'writer (ssh-writer conn-ds sink local-identification))

    (on-stop (stop-actor-system))

    (at conn-ds
      (once
       [(message (ssh-identification-line $remote-identification))
        (cond
          [(regexp-match #rx"^SSH-2\\.0-.*" remote-identification)
           (send! (inbound-credit 1))
           (spawn
             #:name 'session
             (ssh-session conn-ds ground-ds local-identification remote-identification 'server))]
          [else
           (log-error "Invalid peer identification string ~v" remote-identification)
           (stop-actor-system)])])

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

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


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