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

(require bitsyntax)
(require syndicate/drivers/timer)

(require "crypto.rkt")
(require "oakley-groups.rkt")
(require "ssh-host-key.rkt")
(require "ssh-numbers.rkt")
(require "ssh-message-types.rkt")
(require "ssh-exceptions.rkt")
(require "ssh-transport.rkt")
(require "ssh-channel.rkt")

(provide rekey-interval
	 rekey-volume
	 ssh-session)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Data definitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A RekeyState is one of
;; - a (rekey-wait Number Number), representing a time or
;;   transfer-amount by which rekeying should be started
;; - a (rekey-local SshMsgKexinit), when we've sent our local
;;   algorithm list and are waiting for the other party to send theirs
;; - a (rekey-in-progress KeyExchangeState), when both our local
;;   algorithm list has been sent and the remote one has arrived and the
;;   actual key exchange has begun
(struct rekey-wait (deadline threshold-bytes) #:transparent)
(struct rekey-local (local-algorithms) #:transparent)
(struct rekey-in-progress (state) #:transparent)

;; An AuthenticationState is one of
;; - #f, for not-yet-authenticated
;; - an (authenticated String String), 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,
;; the exchange values, and the shared secret to get the final hash.
(struct exchange-hash-info (client-id
			    server-id
			    client-kexinit-bytes
			    server-kexinit-bytes)
	#:transparent)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parameters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define rekey-interval (make-parameter 3600))
(define rekey-volume (make-parameter 1000000000))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Packet dispatch and handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (task Nat Byte Bytes SshMsg)
;; (task-complete Nat)
;; Message handlers respond to `task` messages, eventually sending `task-complete`.
(struct task (seq packet-type packet message) #:prefab)
(struct task-complete (seq) #:prefab)

(define-event-expander with-incoming-task
  (syntax-rules ()
    [(_ (seq-id type-byte packet-pattern message-pattern) body ...)
     (with-incoming-task* when (seq-id type-byte packet-pattern message-pattern) body ...)]))

(define-syntax-rule
  (with-incoming-task/react conn-ds (seq-id type-byte packet-pattern message-pattern) body ...)
  (react
    (at conn-ds
      (with-incoming-task* stop-when (seq-id type-byte packet-pattern message-pattern)
        body ...))))

(define-event-expander with-incoming-task*
  (syntax-rules ()
    [(_ when-stx (seq-id type-byte packet-pattern message-pattern) body ...)
     (when-stx (message (task ($ seq-id _) type-byte packet-pattern message-pattern))
               body ...
               (send! this-target (task-complete seq-id)))]))

(define-syntax-rule (with-assertion-presence ds assertion
                      #:on-present [body-present ...]
                      #:on-absent [body-absent ...])
  (let ((assertion-present #f))
    (at ds (when (asserted assertion)
             (set! assertion-present #t)
             body-present ...))
    (sync! ds (when (not assertion-present)
                (void)
                body-absent ...))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Key Exchange
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (rekey-in-seconds-or-bytes delta-seconds delta-bytes total-transferred)
  (rekey-wait (+ (current-seconds) delta-seconds)
	      (+ total-transferred delta-bytes)))

;; DS (SshMsgKexinit -> Symbol) SshMsgKexinit SshMsgKexinit -> Symbol
;; Computes the name of the "best" algorithm choice at the given
;; getter, using the rules from the RFC and the client and server
;; algorithm precedence lists.
(define (best-result conn-ds getter client-algs server-algs)
  (define client-list0 (getter client-algs))
  (define server-list (getter server-algs))
  (let loop ((client-list client-list0))
    (cond
      ((null? client-list) (disconnect-with-error/local-info
                            conn-ds
                            `((client-list ,client-list0)
                              (server-list ,server-list))
                            SSH_DISCONNECT_KEY_EXCHANGE_FAILED
                            "Could not agree on a suitable algorithm for ~v"
                            getter))
      ((memq (car client-list) server-list) (car client-list))
      (else (loop (cdr client-list))))))

;; HashFunction ExchangeHashInfo Bytes Natural Natural Natural -> Bytes
;; Computes the session ID as defined by SSH's DH key exchange method.
(define (dh-exchange-hash hash-alg hash-info host-key e f k)
  (let ((block-to-hash
	 (bit-string->bytes
	  (bit-string ((exchange-hash-info-client-id hash-info) :: (t:string))
		      ((exchange-hash-info-server-id hash-info) :: (t:string))
		      ((exchange-hash-info-client-kexinit-bytes hash-info) :: (t:string))
		      ((exchange-hash-info-server-kexinit-bytes hash-info) :: (t:string))
		      (host-key :: (t:string))
		      (e :: (t:mpint))
		      (f :: (t:mpint))
		      (k :: (t:mpint))))))
    (hash-alg block-to-hash)))

;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void
;; Performs the server's half of the Diffie-Hellman key exchange protocol.
(define (perform-server-key-exchange conn-ds hash-info kex-alg host-key-alg finish)
  (match kex-alg
    ['diffie-hellman-group14-sha256
     (define group dh:oakley-group-14)
     (define private-key (generate-private-key group))
     (match-define (list 'dh 'public p g public-key-as-integer)
       (pk-key->datum private-key 'rkt-public))
     (with-incoming-task/react conn-ds (seq 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)
       (define-values (host-key-private host-key-public) (host-key-algorithm->keys host-key-alg))
       (define host-key-bytes (pieces->ssh-host-key (public-key->pieces host-key-public)))
       (define exchange-hash (dh-exchange-hash hash-alg
                                               hash-info
                                               host-key-bytes
                                               e
                                               public-key-as-integer
                                               (bit-string->integer shared-secret #t #f)))
       (define h-signature (host-key-signature host-key-private host-key-alg exchange-hash))
       (send! conn-ds (outbound-packet
                       (ssh-msg-kexdh-reply (bit-string->bytes host-key-bytes)
                                            public-key-as-integer
                                            (bit-string->bytes h-signature))))
       (finish shared-secret exchange-hash hash-alg))]
    [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
                              "Bad key-exchange algorithm ~v" kex-alg)]))

;; DS ExchangeHashInfo Symbol Symbol (Bytes Bytes Symbol -> Void) -> Void
;; Performs the client's half of the Diffie-Hellman key exchange protocol.
(define (perform-client-key-exchange conn-ds hash-info kex-alg host-key-alg finish)
  (match kex-alg
    ['diffie-hellman-group14-sha256
     (define group dh:oakley-group-14)
     (define private-key (generate-private-key group))
     (match-define (list 'dh 'public p g public-key-as-integer)
       (pk-key->datum private-key 'rkt-public))
     (send! conn-ds (outbound-packet (ssh-msg-kexdh-init public-key-as-integer)))
     (with-incoming-task/react conn-ds (seq 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)
       (define host-public-key (pieces->public-key (ssh-host-key->pieces host-key-bytes)))
       (define exchange-hash (dh-exchange-hash hash-alg
                                               hash-info
                                               host-key-bytes
                                               public-key-as-integer
                                               f
                                               (bit-string->integer shared-secret #t #f)))
       (verify-host-key-signature! host-public-key host-key-alg exchange-hash h-signature)
       (finish shared-secret exchange-hash hash-alg))]
    [_ (disconnect-with-error conn-ds SSH_DISCONNECT_KEY_EXCHANGE_FAILED
                              "Bad key-exchange algorithm ~v" kex-alg)]))

(define (do-kexinit conn-ds
                    ground-ds
                    #:packet packet
                    #:message message
                    #:rekey-state rekey-state
                    #:is-server? is-server?
                    #:local-id local-id
                    #:remote-id remote-id
                    #:session-id session-id
                    #:total-transferred total-transferred
                    #:discard-next-packet? discard-next-packet?)
  (define local-algs
    (match (rekey-state)
      [(? rekey-wait?) ((local-algorithm-list))]
      [(rekey-local local-algs) local-algs]
      [(? rekey-in-progress?)
       (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR
                              "Received SSH_MSG_KEXINIT during ongoing key exchange")]))
  (define encoded-local-algs (ssh-message-encode local-algs))
  (define remote-algs message)
  (define encoded-remote-algs packet)

  (define c (if is-server? remote-algs local-algs))
  (define s (if is-server? local-algs remote-algs))

  (define kex-alg (best-result conn-ds ssh-msg-kexinit-kex_algorithms c s))
  (define host-key-alg (best-result conn-ds ssh-msg-kexinit-server_host_key_algorithms c s))
  (define c2s-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_client_to_server c s))
  (define s2c-enc (best-result conn-ds ssh-msg-kexinit-encryption_algorithms_server_to_client c s))
  (define c2s-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_client_to_server c s))
  (define s2c-mac (best-result conn-ds ssh-msg-kexinit-mac_algorithms_server_to_client c s))
  (define c2s-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_client_to_server c s))
  (define s2c-zip (best-result conn-ds ssh-msg-kexinit-compression_algorithms_server_to_client c s))
  ;; Ignore languages.
  ;; Don't check the reserved field here, either. TODO: should we?

  (define (guess-matches? chosen-value getter)
    (let ((remote-choices (getter remote-algs)))
      (and (pair? remote-choices) ;; not strictly necessary because of
				  ;; the error behaviour of
				  ;; best-result.
	   (eq? (car remote-choices) ;; the remote peer's guess for this parameter
		chosen-value))))

  (define should-discard-first-kex-packet
    (and (ssh-msg-kexinit-first_kex_packet_follows remote-algs)
	 ;; They've already transmitted their guess. Does their guess match
	 ;; what we've actually selected?
	 (not (and
	       (guess-matches? kex-alg ssh-msg-kexinit-kex_algorithms)
	       (guess-matches? host-key-alg ssh-msg-kexinit-server_host_key_algorithms)
	       (guess-matches? c2s-enc ssh-msg-kexinit-encryption_algorithms_client_to_server)
	       (guess-matches? s2c-enc ssh-msg-kexinit-encryption_algorithms_server_to_client)
	       (guess-matches? c2s-mac ssh-msg-kexinit-mac_algorithms_client_to_server)
	       (guess-matches? s2c-mac ssh-msg-kexinit-mac_algorithms_server_to_client)
	       (guess-matches? c2s-zip ssh-msg-kexinit-compression_algorithms_client_to_server)
	       (guess-matches? s2c-zip ssh-msg-kexinit-compression_algorithms_server_to_client)))))

  (when should-discard-first-kex-packet
    (discard-next-packet? #t))

  (when (rekey-wait? (rekey-state))
    (rekey-state (rekey-local local-algs))
    (send! conn-ds (outbound-packet local-algs)))

  ((if is-server? perform-server-key-exchange perform-client-key-exchange)
   conn-ds
   (if is-server?
       (exchange-hash-info remote-id local-id encoded-remote-algs encoded-local-algs)
       (exchange-hash-info local-id remote-id encoded-local-algs encoded-remote-algs))
   kex-alg
   host-key-alg
   (lambda (shared-secret exchange-hash hash-alg)
     (when (not (session-id)) (session-id exchange-hash)) ;; don't overwrite existing ID
     (define k-h-prefix (bit-string ((bit-string->integer shared-secret #t #f) :: (t:mpint))
                                    (exchange-hash :: binary)))
     (define (derive-key kind needed-bytes-or-false)
       (let extend ((key (hash-alg (bit-string->bytes
                                    (bit-string (k-h-prefix :: binary)
                                                (kind :: binary)
                                                ((session-id) :: binary))))))
         (cond
           ((eq? #f needed-bytes-or-false)
            key)
           ((>= (bytes-length key) needed-bytes-or-false)
            (subbytes key 0 needed-bytes-or-false))
           (else
            (extend (bytes-append key (hash-alg (bit-string->bytes
                                                 (bit-string (k-h-prefix :: binary)
                                                             (key :: binary))))))))))
     (with-incoming-task/react conn-ds (seq 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.
       (rekey-state (rekey-in-seconds-or-bytes (rekey-interval)
                                               (rekey-volume)
                                               (total-transferred)))
       (send! conn-ds 'enable-service-request-handler)
       (send! conn-ds (outbound-packet (ssh-msg-newkeys)))
       (send! conn-ds (new-keys is-server?
                                (embedded derive-key)
                                c2s-enc s2c-enc
                                c2s-mac s2c-mac
                                c2s-zip s2c-zip))
       (send! ground-ds (SetTimer 'rekey-timer
                                  (* (rekey-wait-deadline (rekey-state)) 1000)
                                  (TimerKind-absolute)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Service request manager and user authentication
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (service-request-handler conn-ds)
  (define-field authentication-state #f)

  (at conn-ds
    (assert #:when (authentication-state) (authentication-state))

    (with-incoming-task (seq SSH_MSG_SERVICE_REQUEST _ (ssh-msg-service-request $service))
      (match service
        [#"ssh-userauth"
         (cond
           [(authentication-state)
            (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
                                   "Repeated authentication is not permitted")]
           [else
            (send! conn-ds (outbound-packet (ssh-msg-service-accept service)))
            (with-incoming-task/react conn-ds
              (seq 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! conn-ds (outbound-packet (ssh-msg-userauth-success)))
                 (authentication-state (authenticated user-name service-name))
                 (react
                   (at conn-ds
                     (with-incoming-task (seq SSH_MSG_USERAUTH_REQUEST _ _)
                       ;; RFC4252 section 5.1 page 6
                       )))
                 (let ((a (authentication-state)))
                   (spawn #:name 'connection-service (start-connection-service conn-ds a)))]
                [else
                 (send! conn-ds (outbound-packet (ssh-msg-userauth-failure '(none) #f)))]))])]
        [_
         (disconnect-with-error SSH_DISCONNECT_SERVICE_NOT_AVAILABLE
                                "Service ~v not supported"
                                service)]))))

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

;; (define (remf proc lst)
;;   (cond [(null? lst) '()]
;; 	[(proc (car lst)) (cdr lst)]
;; 	[else (cons (car lst) (remf proc (cdr lst)))]))

;; ;; ChannelName -> ChannelState -> Boolean
;; (define ((ssh-channel-name=? cname) c)
;;   (equal? (ssh-channel-name c) cname))

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

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

;; ;; ChannelName Connection -> Connection
;; (define (discard-channel cname conn)
;;   (struct-copy connection conn
;;    [channels
;;     (remf (ssh-channel-name=? cname) (connection-channels conn))]))

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

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

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

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Connection service
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (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 (start-connection-service conn-ds authentication)
  (match-define (authenticated user-name _service-name) authentication)

  (handle-msg-channel-open 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))

  ;; (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) _)
  ;;                                                       (on-presence (respond-to-opened-outbound-channel conn cname)))))
  ;; (observe-publishers (channel-message (channel-stream-name ? (channel-name #t ? ?)) ?)
  ;;                     (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
  ;;       (at conn-ds
  ;;         (when (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
;; 						   remote-ref
;; 						   initial-window-size
;; 						   maximum-packet-size
;; 						   extra-request-data*)
;;     message)
;;   (define ch (get-channel conn local-ref))
;;   (define extra-request-data (bit-string->bytes extra-request-data*))
;;   (define outbound-stream (channel-stream-name #f (ssh-channel-name ch)))
;;   (transition (update-channel (ssh-channel-name ch)
;; 			      (lambda (c)
;; 				(struct-copy ssh-channel c
;; 					     [remote-ref remote-ref]
;; 					     [outbound-packet-size maximum-packet-size]))
;; 			      conn)
;;     (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-failure packet message conn)
;;   (match-define (ssh-msg-channel-open-failure local-ref
;; 					      reason
;; 					      description*
;; 					      _)
;;     message)
;;   (define ch (get-channel conn local-ref))
;;   (define description (bit-string->bytes description*))
;;   (define inbound-stream (channel-stream-name #t (ssh-channel-name ch)))
;;   (sequence-actions (transition conn)
;;     (send-message (channel-message inbound-stream
;; 				   (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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ssh-session conn-ds
                     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)
  (define-field total-transferred 0)
  (define-field discard-next-packet? #f)

  (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 (seq SSH_MSG_IGNORE _ (ssh-msg-ignore _)))

    (with-incoming-task (seq 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 _ _ _)))
      (log-info (format "Received SSHv2 SSH_MSG_DEBUG packet ~v" message)))

    (with-incoming-task (seq SSH_MSG_KEXINIT $packet
                             ($ message (ssh-msg-kexinit _ _ _ _ _ _ _ _ _ _ _ _ _)))
      (do-kexinit conn-ds
                  ground-ds
                  #:packet packet
                  #:message message
                  #:rekey-state rekey-state
                  #:is-server? (case session-role ((client) #f) ((server) #t))
                  #:local-id local-identification-string
                  #:remote-id peer-identification-string
                  #:session-id session-id
                  #:total-transferred total-transferred
                  #:discard-next-packet? discard-next-packet?)))

  (react
    (at conn-ds
      (stop-when (message 'enable-service-request-handler)
        (spawn #:name 'service-request-handler (service-request-handler conn-ds)))))

  (define (maybe-rekey)
    (match (rekey-state)
      [(rekey-wait deadline threshold-bytes)
       (when (or (>= (current-seconds) deadline)
                 (>= (total-transferred) threshold-bytes))
         (define algs ((local-algorithm-list)))
         (send! conn-ds (outbound-packet algs))
         (rekey-state (rekey-local algs)))]
      [_ (void)]))

  (at ground-ds
    (when (message (TimerExpired 'rekey-timer _))
      (maybe-rekey)))

  (at conn-ds
    (when (message (outbound-byte-credit $amount))
      (total-transferred (+ (total-transferred) amount))
      (maybe-rekey))

    (when (message (inbound-packet $sequence-number $payload $message $transfer-size))
      (if (discard-next-packet?)
          (begin (discard-next-packet? #f)
                 (send! conn-ds (inbound-credit 1)))
          (let ((packet-type-number (bytes-ref payload 0)))
            (if (and (not (rekey-wait? (rekey-state)))
                     (or (not (ssh-msg-type-transport-layer? packet-type-number))
                         (= packet-type-number SSH_MSG_SERVICE_REQUEST)
                         (= packet-type-number SSH_MSG_SERVICE_ACCEPT)))
                ;; We're in the middle of some phase of an active key-exchange,
                ;; and received a packet that's for a higher layer than the
                ;; transport layer, or one of the forbidden types given at the
                ;; send of RFC4253 section 7.1.
                (disconnect-with-error conn-ds SSH_DISCONNECT_PROTOCOL_ERROR
                                       "Packets of type ~v forbidden while in key-exchange"
                                       packet-type-number)
                ;; We're either idling, or it's a permitted packet type while
                ;; performing key exchange. Dispatch it.
                (react
                  (on-start
                   (send! conn-ds (task sequence-number packet-type-number payload message)))
                  (with-assertion-presence conn-ds
                    (Observe (:pattern (task ,_ packet-type-number ,_ ,_)) _)
                    #:on-present []
                    #:on-absent [(send! conn-ds (outbound-packet (ssh-msg-unimplemented sequence-number)))
                                 (send! conn-ds (task-complete sequence-number))])
                  (at conn-ds (stop-when (message (task-complete sequence-number))))
                  (on-stop (send! conn-ds (inbound-credit 1)))))))
      (total-transferred (+ (total-transferred) transfer-size))
      (maybe-rekey))))