#lang imperative-syndicate
;; TCP/IP driver interface.
;;
;; A nice refinement would be to introduce something like a
;; `(tcp-error id _)` assertion, for when something goes wrong
;; listening or connecting. At present, for example, if connecting to
;; some other host that isn't listening, the driver pretends the
;; connection is open for an infinitesimal instant before closing.
;; This would be nicer if it never signalled "open" at all, instead
;; asserting something like `tcp-error` until interest in the
;; connection goes away.
;;
;; TODO: This protocol is overly simplified.
;; a) no flow control
;; b) no facility for separate shutdown of inbound/outbound streams

(provide (struct-out tcp-connection)
         (struct-out tcp-connection-peer)
         (struct-out tcp-accepted)
         (struct-out tcp-rejected)
         (struct-out tcp-out)
         (struct-out tcp-in)
         (struct-out tcp-in-line)

         (struct-out tcp-address)
         (struct-out tcp-listener))

(define-logger syndicate/tcp)

(require racket/exn)
(require (prefix-in tcp: racket/tcp))
(require (only-in racket/port read-bytes-avail!-evt))

(require racket/unit)
(require net/tcp-sig)
(require net/tcp-unit)

(require syndicate/support/bytes)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Protocol messages

(assertion-struct tcp-connection (id spec))
(assertion-struct tcp-connection-peer (id addr))
(assertion-struct tcp-accepted (id))
(assertion-struct tcp-rejected (id exn))
(message-struct tcp-out (id bytes))
(message-struct tcp-in (id bytes))
(message-struct tcp-in-line (id bytes))

(assertion-struct tcp-address (host port))
(assertion-struct tcp-listener (port))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ground-level communication messages

(message-struct raw-tcp-accepted (local-addr remote-addr cin cout))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Driver

(spawn #:name 'drivers/tcp

       (during/spawn (observe (tcp-connection _ (tcp-listener $port)))
         #:name (list 'drivers/tcp 'listener port)
         (run-listener port))

       (during/spawn (tcp-connection $id (tcp-address $host $port))
         #:name (list 'drivers/tcp 'outbound id host port)
         (match (with-handlers ([exn:fail? (lambda (e) (list e))])
                  (define-values (cin cout) (tcp:tcp-connect host port))
                  (list cin cout))
           [(list e) (assert (tcp-rejected id e))]
           [(list cin cout)
            (assert (tcp-accepted id))
            (define unblock! (run-connection id cin cout))
            (unblock!)]))

       (during/spawn (observe (tcp-in-line $id _))
         #:name (list 'drivers/tcp 'line-reader id)
         (field [buffer #""])
         (on (message (tcp-in id $bs)) (buffer (bytes-append (buffer) bs)))
         (begin/dataflow
           (define newline-pos (bytes-index (buffer) (char->integer #\newline)))
           (when newline-pos
             (define line (subbytes (buffer) 0 newline-pos))
             (buffer (subbytes (buffer) (+ newline-pos 1)))
             (send! (tcp-in-line id line))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Listener

(define (run-listener port)
  (define server-addr (tcp-listener port))
  (define listener (tcp:tcp-listen port 128 #t))
  (define control-ch (make-channel))

  (thread (lambda ()
            (let loop ((blocked? #t))
              (sync (handle-evt control-ch
                                (match-lambda
                                  ['unblock (loop #f)]
                                  ['quit (void)]))
                    (if blocked?
                        never-evt
                        (handle-evt (tcp:tcp-accept-evt listener)
                                    (lambda (cin+cout)
                                      (match-define (list cin cout) cin+cout)
                                      (define-values
                                        (local-hostname local-port remote-hostname remote-port)
                                        (tcp:tcp-addresses cin #t))
                                      (ground-send!
                                       (inbound
                                        (raw-tcp-accepted server-addr
                                                          (tcp-address remote-hostname remote-port)
                                                          cin
                                                          cout)))
                                      (loop blocked?))))))
            (tcp:tcp-close listener)
            (signal-background-activity! -1)))
  (signal-background-activity! +1)

  (on-start (channel-put control-ch 'unblock))
  (on-stop (channel-put control-ch 'quit))

  (on (message (inbound (raw-tcp-accepted server-addr $remote-addr $cin $cout)))
      (define id (seal (list port remote-addr)))
      (spawn #:name (list 'drivers/tcp 'inbound id)
             (assert (tcp-connection id server-addr))
             (assert (tcp-connection-peer id remote-addr))
             (define unblock! (run-connection id cin cout))
             (on (asserted (tcp-accepted id)) (unblock!))
             (stop-when (asserted (tcp-rejected id _)))
             (stop-when (retracted (tcp-accepted id))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Connection

(define (run-connection id cin cout)
  (define control-ch (make-channel))
  (thread (lambda () (connection-thread control-ch id cin)))
  (signal-background-activity! +1)

  (define (shutdown-connection!)
    (when control-ch
      (channel-put control-ch 'quit)
      (set! control-ch #f))
    (when cout
      (close-output-port cout)
      (set! cout #f)))

  (on-stop (shutdown-connection!))

  (on (message (inbound (tcp-in id $eof-or-bs)))
      (if (eof-object? eof-or-bs)
          (stop-current-facet)
          (send! (tcp-in id eof-or-bs))))

  (define-syntax-rule (trap-exns body ...)
    (with-handlers ([(lambda (e) (not (exn:break? e)))
                     (lambda (e)
                       (shutdown-connection!)
                       (raise e))])
      body ...))

  (on (message (tcp-out id $bs))
      (trap-exns
       (if (string? bs)
           (write-string bs cout)
           (write-bytes bs cout))
       (flush-output cout)))

  (let ((unblocked? #f))
    (lambda ()
      (when (not unblocked?)
        (set! unblocked? #t)
        (when control-ch (channel-put control-ch 'unblock))))))

(define (connection-thread control-ch id cin)
  (let loop ((blocked? #t))
    (sync (handle-evt control-ch
                      (match-lambda
                        ['unblock (loop #f)]
                        ['quit (void)]))
          (if blocked?
              never-evt
              (handle-evt (read-bytes-avail-evt 32768 cin)
                          (lambda (eof-or-bs)
                            (ground-send! (inbound (tcp-in id eof-or-bs)))
                            (loop (or blocked? (eof-object? eof-or-bs))))))))
  (close-input-port cin)
  (signal-background-activity! -1))

(define (read-bytes-avail-evt len input-port)
  (guard-evt
   (lambda ()
     (let ([bstr (make-bytes len)])
       (handle-evt
        (read-bytes-avail!-evt bstr input-port)
        (lambda (v)
          (if (number? v)
              (if (= v len) bstr (subbytes bstr 0 v))
              v)))))))
