#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/timer)
(require syndicate/drivers/tcp)
(require syndicate/dataspace)

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

(module+ main
  (actor-system/dataspace (ds)
    (spawn-timer-driver ds)
    (spawn-tcp-driver ds)
    (spawn #:name 'ssh-tcp-listener
           (at ds
             (during/spawn (Connection $conn (TcpLocal "0.0.0.0" 29418))
               #:name (list 'ssh conn)
               (session ds conn))))))

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

(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 conn)
  (define local-identification #"SSH-2.0-RacketSSH_0.0")

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

  (define transfer-control
    (object #:name 'transfer-control
            [#:message 'transfer-control (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" conn))
       (actor-group
         #:link? #t
         (define conn-ds (dataspace #:name (gensym 'conn-ds)))

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

         ;; 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-when (asserted (Observe (:pattern (inbound-credit ,_)) _))
               (send! conn-ds (inbound-credit 1))

               (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)))
         ;;   (when (message $m)
         ;;     (log-info ">> ~v" m)))

         (at conn-ds
           (when (asserted (protocol-error $reason-code $message _ $originated-at-peer?))
             (when (not originated-at-peer?)
               (send! conn-ds
                 (outbound-packet (ssh-msg-disconnect reason-code
                                                      (string->bytes/utf-8 message)
                                                      #""))))
             (sync! conn-ds (stop-actor-system)))))]))

  (void))

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

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