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

#lang syndicate

(require "wire-protocol.rkt")
(require "internal-protocol.rkt")
(require "turn.rkt")

(require/activate "heartbeat.rkt")

(spawn #:name 'server-factory

       ;; Previously, we just had server-envelope. Now, we have both
       ;; server-envelope and server-proposal. While not everything
       ;; decided is (locally) suggested, it is true that everything
       ;; suggested is decided (in this implementation at least),
       ;; and the following clauses reflect this:
       (on (asserted (server-proposal $scope $assertion))
           (assert! (server-envelope scope assertion)))
       (on (retracted (server-proposal $scope $assertion))
           (retract! (server-envelope scope assertion)))
       (on (message (server-proposal $scope $body))
           (send! (server-envelope scope body)))
       (on (asserted (observe (server-envelope $scope $spec)))
           (assert! (server-proposal scope (observe spec))))
       (on (retracted (observe (server-envelope $scope $spec)))
           (retract! (server-proposal scope (observe spec))))

       (during/spawn (server-poa $id)
         (define root-facet (current-facet))
         (assert (server-poa-ready id))
         (on-start
          (match (let-event [(message (message-poa->server id $p))] p)
            [(Connect scope) (react (connected id scope root-facet))]
            [_ (send! (message-server->poa id (Err 'connection-not-setup #f)))]))))

(define (connected id scope root-facet)
  (define endpoints (hash))

  (define turn (turn-recorder (lambda (items) (send! (message-server->poa id (Turn items))))))

  (assert (server-active scope))

  (define (send-error! detail [context #f])
    (send! (message-server->poa id (Err detail context)))
    (reset-turn! turn)
    (stop-facet root-facet))

  (define reset-heartbeat! (heartbeat (list 'server id scope)
                                      (lambda (m) (send! (message-server->poa id m)))
                                      (lambda () (stop-facet root-facet))))

  (on (message (message-poa->server id $p))
      (reset-heartbeat!)
      (match p
        [(Turn items)
         (for [(item (in-list items))]
           (match item
             [(Assert ep a)
              (if (hash-has-key? endpoints ep)
                  (send-error! 'duplicate-endpoint item)
                  (react
                   (define ep-facet (current-facet))
                   (set! endpoints (hash-set endpoints ep ep-facet))
                   (on-stop (set! endpoints (hash-remove endpoints ep)))

                   (assert (server-proposal scope a))

                   (when (observe? a)
                     (define ((! ctor) cs) (extend-turn! turn (ctor ep cs)))
                     (add-observer-endpoint!
                      (lambda () (server-envelope scope (observe-specification a)))
                      #:on-add (! Add)
                      #:on-remove (! Del)
                      #:on-message (! Msg)))))]
             [(Clear ep)
              (match (hash-ref endpoints ep #f)
                [#f (send-error! 'nonexistent-endpoint item)]
                [ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])]
             [(Message body)
              (send! (server-proposal scope body))]))]
        [(Ping)
         (send! (message-server->poa id (Pong)))]
        [(Pong)
         (void)]
        [_
         (send-error! 'invalid-message p)])))