#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/drivers/stream)
         (all-from-out syndicate/schemas/gen/tcp))

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

(require (for-syntax racket/base))

(define-logger syndicate/drivers/tcp)

(provide-service [ds]
  (with-services [syndicate/drivers/stream]
    (at ds
      (during/spawn (StreamListener (TcpLocal $host $port) $peer)
        #:name (TcpLocal host port)
        (run-listener ds peer host port))

      (during/spawn (StreamConnect (TcpRemote $host $port) $peer)
        #:name (TcpRemote host port)
        (run-outbound ds peer host port)))))

(define (run-listener ds peer 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 'listen-thread host port)
   (lambda (facet)
     (with-connection-error-guard ds peer
       (lambda (message)
         (turn! facet (lambda ()
                        (at ds (assert (TcpListenError (TcpLocal host port) message)))
                        (at peer (assert (ConnectionHandler-rejected message))))))
       (lambda ()
         (define listener (tcp-listen port 512 #t host))
         (lambda ()
           (let loop ()
             (define connection-custodian (make-custodian))
             (define-values (i o) (parameterize ((current-custodian connection-custodian))
                                    (tcp-accept listener)))
             (turn! facet (lambda () (spawn-connection ds connection-custodian i o peer)))
             (loop))))))))

(define (tcp-ends p)
  (call-with-values (lambda () (tcp-addresses p #t))
                    (lambda (lh lp rh rp) (list (TcpLocal lh lp) (TcpRemote rh rp)))))

(define (spawn-connection ds custodian i o peer)
  (match-define (and ends (list (and local-end (TcpLocal local-host local-port))
                                (and remote-end (TcpRemote remote-host remote-port))))
    (tcp-ends i))
  (define name (format "[~a:~a::~a:~a]" local-host local-port remote-host remote-port))
  (log-syndicate/drivers/tcp-info "Connection ~a established" name)
  (spawn #:name name
         (actor-add-exit-hook! this-actor (lambda ()
                                            (close-input-port i)
                                            (close-output-port o)))

         (define-field facet-count 2)
         (define source #f)
         (define sink #f)

         (react (on-stop (facet-count (- (facet-count) 1))
                         (close-input-port i))
                (set! source (port-source i #:custodian custodian))
                (at ds (assert (TcpPeerInfo source local-end remote-end))))

         (react (on-stop (facet-count (- (facet-count) 1))
                         (close-output-port o))
                (set! sink (port-sink o))
                (at ds (assert (TcpPeerInfo sink local-end remote-end))))

         (at peer
           (assert #:when (positive? (facet-count))
                   (ConnectionHandler-connected source sink)))))

(define (with-connection-error-guard ds peer error-proc proc)
  ((with-handlers ([exn:fail:network? (lambda (e) (lambda () (error-proc (exn->string e))))])
     (proc))))

(define (run-outbound ds peer host port)
  (with-connection-error-guard ds peer
    (lambda (message)
      (at peer (assert (ConnectionHandler-rejected message))))
    (lambda ()
      (define connection-custodian (make-custodian))
      (define-values (i o) (parameterize ((current-custodian connection-custodian))
                             (tcp-connect host port)))
      (lambda () (spawn-connection ds connection-custodian i o peer)))))