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

(provide (all-from-out syndicate/schemas/gen/tcp)
         spawn-tcp-driver
         accept-connection
         establish-connection
         send-credit
         send-line
         send-data
         send-eof)

(require racket/async-channel)
(require racket/tcp)
(require racket/port)
(require (only-in racket/exn exn->string))
(require syndicate/driver-support)
(require syndicate/functional-queue)
(require syndicate/schemas/gen/tcp)
(require syndicate/schemas/gen/dataspace-patterns)

(require (for-syntax racket/base))

(define-logger syndicate/drivers/tcp)

(define (spawn-tcp-driver ds)
  (spawn
    #:name 'tcp-driver
    #:daemon? #t

    (at ds
      (during/spawn
          (Observe (:pattern (Connection ,_ (TcpInbound ,(DLit $host) ,(DLit $port)))) _)
        #:name (TcpInbound host port)
        (run-listener ds host port))

      (during/spawn
          (Connection $local-peer (TcpOutbound $host $port))
        #:name (TcpOutbound host port)
        (run-outbound ds local-peer host port)))))

(define (run-listener ds host port)
  (on-start (log-syndicate/drivers/tcp-info "+listener on ~v ~v" host port))
  (on-stop  (log-syndicate/drivers/tcp-info "-listener on ~v ~v" host port))
  (linked-thread
   #:name (list (TcpInbound host port) 'thread)
   (lambda (facet)
     (define listener (tcp-listen port 512 #t host))
     (let loop ()
       (define connection-custodian (make-custodian))
       (define-values (i o) (parameterize ((current-custodian connection-custodian))
                              (tcp-accept listener)))
       (turn! facet
              (lambda () (spawn-inbound ds connection-custodian i o (TcpInbound host port))))
       (loop)))))

(define (mode->line-terminator mode)
  (match mode
    [(LineMode-lf) "\n"]
    [(LineMode-crlf) "\r\n"]))

(define (render-line line mode)
  (string->bytes/utf-8 (string-append line (mode->line-terminator mode))))

(define (run-outbound ds local-peer host port)
  (define connection-custodian (make-custodian))
  ((with-handlers ([exn:fail:network?
                    (lambda (e)
                      (lambda () (at local-peer (assert (ActiveSocket-close (exn->string e))))))])
     (define-values (i o) (parameterize ((current-custodian connection-custodian))
                            (tcp-connect host port)))
     (lambda ()
       (define name (call-with-values (lambda () (tcp-addresses i #t)) list))
       (on-stop (close-input-port i)
                (close-output-port o))
       (define issue-credit (start-inbound-relay connection-custodian name (lambda () local-peer) i))
       (define relay (outbound-relay name o))
       (at local-peer
         (assert (ActiveSocket-controller
                  (object #:name (list name 'socket)
                          [#:asserted (Socket-Credit c) (issue-credit c)]
                          [#:asserted (Socket-line line mode) (relay (render-line line mode))]
                          [#:asserted (Socket-data data) (relay data)]
                          [#:asserted (Socket-eof) (close-output-port o)]))))))))

(define (spawn-inbound ds custodian i o spec)
  (define name (call-with-values (lambda () (tcp-addresses i #t)) list))
  (spawn
    #:name name
    (on-stop (close-input-port i)
             (close-output-port o))

    (define issue-credit #f)
    (define active-controller #f)
    (define relay (outbound-relay name o))
    (at ds
      (assert (Connection
               (object
                 #:name (list name 'active-socket)
                 [#:asserted (ActiveSocket-controller controller)
                  (log-syndicate/drivers/tcp-debug "~v controller for ~v" controller this-actor)
                  (when (not active-controller)
                    (set! issue-credit
                          (start-inbound-relay custodian name (lambda () active-controller) i)))
                  (set! active-controller controller)
                  #:retracted
                  (when (eq? controller active-controller)
                    (log-syndicate/drivers/tcp-debug "peer withdrawn ~v" this-actor)
                    (stop-current-facet))]
                 [#:asserted (ActiveSocket-close message)
                  (log-syndicate/drivers/tcp-debug "closing ~v:\n~a" this-actor message)
                  (stop-current-facet)]
                 [#:asserted (ActiveSocket-Socket (Socket-Credit c))
                  (if issue-credit
                      (issue-credit c)
                      (log-syndicate/drivers/tcp-warning
                       "Socket-Credit ~v ignored because no controller present" c))]
                 [#:asserted (ActiveSocket-Socket (Socket-line line mode))
                  (relay (render-line line mode))]
                 [#:asserted (ActiveSocket-Socket (Socket-data data))
                  (relay data)]
                 [#:asserted (ActiveSocket-Socket (Socket-eof))
                  (close-output-port o)])
               spec)))))

(define (start-inbound-relay custodian name target-proc i)
  (define eof-received? #f)
  (define control-ch (make-async-channel))
  (linked-thread
   #:name (list name 'input-thread)
   #:custodian custodian
   #:peer (object #:name 'inbound-relay-monitor
                  [#:asserted _
                   #:retracted
                   (close-input-port i)
                   (when (not eof-received?) (stop-current-facet))])
   (lambda (facet)
     (define (update-count remaining-count mode q)
       (if (zero? remaining-count)
           q
           (undequeue (cons remaining-count mode) q)))
     (let loop ((credits (make-queue)))
       (sync (handle-evt control-ch
                         (match-lambda
                           [(Credit (CreditAmount-count 0) _mode) (loop credits)]
                           [(Credit (CreditAmount-count n) mode)
                            (loop (match (unenqueue* credits)
                                    [(list q (cons c (== mode))) (enqueue q (cons (+ c n) mode))]
                                    [_ (enqueue credits (cons n mode))]))]
                           [(Credit (CreditAmount-unbounded) mode)
                            (loop (match (unenqueue* credits)
                                    [(list q (cons _ (== mode))) (enqueue q (cons +inf.0 mode))]
                                    [_ (enqueue credits (cons +inf.0 mode))]))]))
             (match (dequeue* credits)
               [(list)
                never-evt]
               [(list (cons count (and mode (CreditMode-bytes))) q)
                (define buffer (make-bytes (inexact->exact (min count 131072))))
                (handle-evt (read-bytes-avail!-evt buffer i)
                            (match-lambda
                              [(? number? read-count)
                               (define bs (subbytes buffer 0 read-count))
                               (log-syndicate/drivers/tcp-debug "inbound data ~v for ~v" bs name)
                               (turn! facet (lambda () (send-data (target-proc) bs)))
                               (loop (update-count (- count read-count) mode q))]
                              [(? eof-object?)
                               (log-syndicate/drivers/tcp-debug "inbound eof for ~v" name)
                               (turn! facet (lambda () (send-eof (target-proc))))]))]
               [(list (cons count (and mode (CreditMode-lines line-mode))) q)
                (handle-evt (read-line-evt i (match line-mode
                                               [(LineMode-lf) 'linefeed]
                                               [(LineMode-crlf) 'return-linefeed]))
                            (match-lambda
                              [(? string? line)
                               (log-syndicate/drivers/tcp-debug "inbound line ~v for ~v" line name)
                               (turn! facet (lambda () (send-line (target-proc) line line-mode)))
                               (loop (update-count (- count 1) mode q))]
                              [(? eof-object?)
                               (log-syndicate/drivers/tcp-debug "inbound eof for ~v" name)
                               (turn! facet (lambda () (send-eof (target-proc))))]))])))))
  (define (issue-credit c)
    (async-channel-put control-ch c))
  issue-credit)

(define-syntax (EPIPE stx)
  (local-require ffi/unsafe)
  (define errno-value (cons (lookup-errno 'EPIPE) 'posix))
  (syntax-case stx ()
    [(_) #`'#,errno-value]))

(define (with-stop-current-facet-on-epipe operation thunk)
  (with-handlers ([(lambda (e)
                     (and (exn:fail:network:errno? e)
                          (equal? (exn:fail:network:errno-errno e) (EPIPE))))
                   (lambda (e)
                     (log-syndicate/drivers/tcp-debug "epipe while ~a" operation)
                     (stop-current-facet))])
    (thunk)))

(define (outbound-relay name o)
  (define flush-pending #f)
  (lambda (payload)
    (log-syndicate/drivers/tcp-debug "outbound data ~v for ~v" payload name)
    (with-stop-current-facet-on-epipe 'writing (lambda () (write-bytes payload o)))
    (when (not flush-pending)
      (set! flush-pending #t)
      (facet-on-end-of-turn! this-facet
                             (lambda ()
                               (set! flush-pending #f)
                               (with-stop-current-facet-on-epipe 'flushing
                                 (lambda () (flush-output o))))))))

(define (accept-connection conn
                           #:initial-credit [initial-credit (CreditAmount-unbounded)]
                           #:initial-mode [initial-mode (CreditMode-bytes)]
                           #:on-data on-data
                           #:on-eof [on-eof void]
                           #:on-credit [on-credit (lambda (c) (void))])
  (at conn
    (assert (ActiveSocket-controller
             (object #:name 'inbound-socket-controller
                     [#:asserted (Socket-Credit c) (on-credit c)]
                     [#:asserted (Socket-line line mode) (on-data line mode)]
                     [#:asserted (Socket-data data) (on-data data)]
                     [#:asserted (Socket-eof) (on-eof)]))))
  (when initial-credit (send-credit conn initial-credit initial-mode)))

(define (establish-connection ds spec
                              #:initial-credit [initial-credit (CreditAmount-unbounded)]
                              #:initial-mode [initial-mode (CreditMode-bytes)]
                              #:on-connected on-connected
                              #:on-data on-data
                              #:on-eof [on-eof void]
                              #:on-credit [on-credit (lambda (c) (void))]
                              #:on-disconnected [on-disconnected (lambda () (stop-current-facet))]
                              #:on-rejected [on-rejected (lambda () (stop-current-facet))])
  (define s
    (object #:name 'outbound-socket
            [#:asserted (ActiveSocket-controller peer)
             (on-connected peer)
             (when initial-credit (send-credit peer initial-credit initial-mode))
             #:retracted
             (on-disconnected)]
            [#:asserted (ActiveSocket-close message) (on-rejected message)]
            [#:asserted (ActiveSocket-Socket (Socket-Credit c)) (on-credit c)]
            [#:asserted (ActiveSocket-Socket (Socket-line line mode)) (on-data line mode)]
            [#:asserted (ActiveSocket-Socket (Socket-data data)) (on-data data)]
            [#:asserted (ActiveSocket-Socket (Socket-eof)) (on-eof)]))
  (at ds (assert (Connection s spec))))

(define (send-credit conn amount unit)
  (send! conn (Socket-Credit (Credit amount unit))))

(define (send-line conn line [mode (LineMode-crlf)])
  (send! conn (Socket-line line mode)))

(define (send-data conn data)
  (send! conn (Socket-data (if (bytes? data) data (string->bytes/utf-8 data)))))

(define (send-eof conn)
  (send! conn (Socket-eof)))