;;;; remote-mailbox-server.scm
;;;; Kon Lovett, Sep '09
;;;; Kon Lovett, Sep '17

;; Issues
;;
;; - Currently the server output port is ignored since the client input port is
;; closed!

(module remote-mailbox-server

(;export
  ;;Common
  ; Parameters
  remote-mailbox-default-tcp-port-no
  remote-mailbox-default-hostname
  ;;Server
  ;Parameters
  remote-mailbox-default-listen
  remote-mailbox-default-auto-create?
  ;Operations
  make-remote-mailbox-server
  make-remote-mailbox-server-thread
  server-local-mailbox
  drop-server-local-mailbox!
  server-local-mailbox-names
  remote-mailbox-server-run!
  remote-mailbox-server-start!
  remote-mailbox-server-stop!
  ;;Queries
  remote-mailbox-server?
  remote-mailbox-server-name
  remote-mailbox-server-auto-create?
  remote-mailbox-server-listener
  remote-mailbox-server-request-limit
  remote-mailbox-server-debug
  ;;Convenience
  local-mailbox-server
  local-mailbox-thread
  local-mailbox-start!
  local-mailbox)

(import scheme
  (chicken base)
  (chicken type)
  (chicken condition)
  (chicken tcp)
  (only (srfi 18)
    mutex-name make-thread thread-start!
    thread-join! thread-terminate!)
  (only (srfi 69)
    make-hash-table hash-table-ref/default
    hash-table-set! hash-table-keys
    hash-table? hash-table-delete!)
  (only miscmacros define-parameter while)
  (only moremacros define-warning-parameter)
  tcp-server
  mailbox
  synch-open
  type-checks
  type-errors
  exn-condition
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)

;;

(define-type mailbox (struct mailbox))
(define-type mailbox-name symbol)

(define-type tcp-port-no fixnum)

(define-type hostname string)

(define-type remote-mailbox-server (struct remote-mailbox-server))

(: make-remote-mailbox-server-condition (string remote-mailbox-server list (or condition symbol list) -> condition))

(: remote-mailbox-server? (* -> boolean : remote-mailbox-server))
(: remote-mailbox-server-name (remote-mailbox-server -> *))
(: remote-mailbox-server-auto-create? (remote-mailbox-server -> boolean))
(: remote-mailbox-server-listener (remote-mailbox-server -> tcp-listener))
(: remote-mailbox-server-request-limit (remote-mailbox-server -> fixnum))
(: remote-mailbox-server-debug (remote-mailbox-server -> *))

(: remote-mailbox-default-listen (#!optional (or boolean procedure) -> procedure))
(: remote-mailbox-default-auto-create? (#!optional boolean -> boolean))

(: make-remote-mailbox-server-thunk (remote-mailbox-server #!optional input-port -> procedure))
(: make-remote-mailbox-server (#!rest -> remote-mailbox-server))
(: make-remote-mailbox-server-thread (remote-mailbox-server -> thread))

(: remote-mailbox-server-run! (remote-mailbox-server -> void))
(: remote-mailbox-server-start! (remote-mailbox-server -> thread))
(: remote-mailbox-server-stop! (remote-mailbox-server -> void))

(: server-local-mailbox (remote-mailbox-server mailbox-name #!optional boolean -> mailbox))
(: drop-server-local-mailbox! (remote-mailbox-server mailbox-name -> void))
(: server-local-mailbox-names (remote-mailbox-server -> (list-of string)))

(: local-mailbox-start! (#!optional * -> void))
(: local-mailbox-server (-> remote-mailbox-server))
(: local-mailbox-thread (-> thread))
(: local-mailbox (mailbox-name #!optional boolean * -> mailbox))

(: *server-local-mailbox (remote-mailbox-server * boolean -> mailbox))

;;; Utilities

;;

(: hash-table-indempotent-ref! (hash-table * (* -> *) --> *))

(define (hash-table-indempotent-ref! ht key f . opts)
  (check-hash-table 'hash-table-indempotent-ref! ht)
  (check-procedure 'hash-table-indempotent-ref! f)
  (let ((def (optional opts #f)))
    (let ((val (hash-table-ref/default ht key def)))
      (if (not (eq? def val)) val
        (let ((val (f def)))
          (if (eq? def val) def
            (begin (hash-table-set! ht key val) val)))))))

(define-check+error-type hash-table)

;;

(define-type mutex (struct mutex))

(: hash-table-keys/%synch (mutex -> list))
(: hash-table-indempotent-ref!/%synch (mutex * (* -> *) --> *))
(: hash-table-delete!/%synch (mutex * -> void))

(define-constructor-%synch make-hash-table)
(define-operation-%synch hash-table-keys)
(define-operation-%synch hash-table-indempotent-ref!)
(define-operation-%synch hash-table-delete!)

(define make-hash-table/%synch make-hash-table-%synch)
(define hash-table-keys/%synch hash-table-keys-%synch)
(define hash-table-indempotent-ref!/%synch hash-table-indempotent-ref!-%synch)
(define hash-table-delete!/%synch hash-table-delete!-%synch)

;;; Conditions

(define (make-remote-mailbox-server-condition msg rmbs args kind)
  (make-exn-condition+
    'remote-mailbox-tcp-server
    msg
    (cons (remote-mailbox-server-name rmbs) args)
    'remote-mailbox kind) )

(define (remote-mailbox-server-mailbox-exception rmbs . args)
  (abort (make-remote-mailbox-server-condition "no such mailbox" rmbs args 'mailbox)) )

(define (remote-mailbox-server-request-exception rmbs . args)
  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request" rmbs args 'request)) )

;;; Server Side

;;

(define-record-type remote-mailbox-server
  (*make-remote-mailbox-server htm nm autof desrl srvr thread lstnr rlim dbg)
  remote-mailbox-server?
  ;FIXME hide server-local-mailbox-map impl details
  (htm remote-mailbox-server-hash-table/%synch)
  (nm remote-mailbox-server-name)
  (autof remote-mailbox-server-auto-create?)
  (desrl remote-mailbox-server-deserializer)
  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
  (lstnr remote-mailbox-server-listener)
  (rlim remote-mailbox-server-request-limit)
  (dbg remote-mailbox-server-debug) )

(define-check+error-type remote-mailbox-server)

;; Parameters

(define-constant DEFAULT-REQUEST-COUNT-LIMIT 10000)

(define (remote-mailbox-listener? x)
  (or (not x) (procedure? x)) )

(define-warning-parameter remote-mailbox-default-listen tcp-listen remote-mailbox-listener
  ;ugh, automagic identifier injection
  (unless obj (set! obj tcp-listen)) )

(define-parameter remote-mailbox-default-auto-create? #t identity)

;; Support

(define (*server-local-mailbox rmbs name create?)
  (hash-table-indempotent-ref!/%synch
    (remote-mailbox-server-hash-table/%synch rmbs)
    name
    (lambda (def) (if create? (make-mailbox name) def))) )

(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
  (while (not (eof-object? (peek-char inp)))
    (let ((req
            (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
              (deserialize inp))) )
      (cond
        ((eq? (void) req)
          ;ignore void transmissions
          )
        ((remote-mailbox-packet? req)
          (let* ((nam
                  (remote-mailbox-packet-key req))
                 (lmb
                  (*server-local-mailbox
                    rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
            (if lmb
              (mailbox-send! lmb (remote-mailbox-packet-value req))
              (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
        (else
          (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )

(define (*remote-mailbox-server-run! rmbs)
  ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )

(define (*make-remote-mailbox-server-thread rmbs)
  (remote-mailbox-server-thread-set! rmbs
    (make-thread
      (lambda () (*remote-mailbox-server-run! rmbs) (print "*** TCP SERVER Returns ***"))
      (remote-mailbox-server-name rmbs)))
  (remote-mailbox-server-thread rmbs) )

(define (*remote-mailbox-server-start! rmbs)
  (thread-start! (*make-remote-mailbox-server-thread rmbs)) )

(define (*remote-mailbox-server-stop! rmbs)
  (handle-exceptions ex
    (void)
    ;
    (tcp-close (remote-mailbox-server-listener rmbs))
    #; ;FIXME run server doesn't return
    (thread-join! (remote-mailbox-server-thread rmbs))
    ;FIXME force terminate thread is a smell!
    (thread-terminate! (remote-mailbox-server-thread rmbs)) ) )

;; Exported

(define (make-remote-mailbox-server
          #!key
          (tcp-port-no (remote-mailbox-default-tcp-port-no))
          (listen (remote-mailbox-default-listen))
          (name (gensym 'rtmbsv))
          (auto-create? (remote-mailbox-default-auto-create?))
          (request-limit DEFAULT-REQUEST-COUNT-LIMIT)
          debug)
  (check-tcp-port-no 'make-remote-mailbox-server tcp-port-no 'tcp-port-no)
  (check-procedure 'make-remote-mailbox-server listen 'listen)
  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
  (let* ((rmbs
          (*make-remote-mailbox-server
            (make-hash-table/%synch)
            name
            auto-create?
            (deserializer)
            #f
            #f
            (listen tcp-port-no)
            request-limit
            debug))
         (tcps
          (make-tcp-server
            (remote-mailbox-server-listener rmbs)
            (make-remote-mailbox-server-thunk rmbs)
            (remote-mailbox-server-request-limit rmbs))) )
    (remote-mailbox-server-tcp-server-set! rmbs tcps)
    rmbs ) )

(define (make-remote-mailbox-server-thread rmbs)
  (*make-remote-mailbox-server-thread
    (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)) )

;;

(define (remote-mailbox-server-run! rmbs)
  (*remote-mailbox-server-run!
    (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)) )

(define (remote-mailbox-server-start! rmbs)
  (*remote-mailbox-server-start!
    (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)) )

(define (remote-mailbox-server-stop! rmbs)
  (*remote-mailbox-server-stop!
    (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)) )

;;

(define (server-local-mailbox rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
  (*server-local-mailbox
    (check-remote-mailbox-server 'server-local-mailbox rmbs)
    (check-mailbox-name 'server-local-mailbox name)
    create?) )

(define (drop-server-local-mailbox! rmbs name)
  (hash-table-delete!/%synch
    (remote-mailbox-server-hash-table/%synch
      (check-remote-mailbox-server 'drop-server-local-mailbox! rmbs))
    (check-mailbox-name 'drop-server-local-mailbox! name)) )

(define (server-local-mailbox-names rmbs)
  (hash-table-keys/%synch
    (remote-mailbox-server-hash-table/%synch
      (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs))) )

;;; Convenience

(define local-mailbox-start!)
(define local-mailbox-server)
(define local-mailbox-thread)
(define local-mailbox)
(let ((+rmbs+ (the (or false remote-mailbox-server) #f))
      (+thrd+ (the (or false thread) #f)))

  (set! local-mailbox-start! (lambda (#!optional debug)
    (unless +rmbs+
      (set! +rmbs+
        (make-remote-mailbox-server
          #:name 'remote-mailbox-default-server
          #:debug debug))
      (set! +thrd+
        (*remote-mailbox-server-start! +rmbs+)) ) ) )

  (set! local-mailbox-server (lambda () +rmbs+))

  (set! local-mailbox-thread (lambda () +thrd+))

  (set! local-mailbox (lambda (name #!optional create? debug)
    (unless +rmbs+ (local-mailbox-start! debug))
    (server-local-mailbox +rmbs+ name create?) ) ) )

) ;module remote-mailbox-server