;;;; 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
  default-remote-mailbox-tcp-port-no
  default-remote-mailbox-hostname
  ;; Server
  ; Parameters
  default-remote-mailbox-listen
  default-remote-mailbox-auto-create?
  ; Operations
  make-remote-mailbox-server
  make-remote-mailbox-server-thread
  local-mailbox-for-server
  drop-local-mailbox!-for-server
  local-mailbox-names-for-server
  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
  ;;DEPERCATED
  default-remote-mailbox-tcp-port
  local-mailbox/server
  drop-local-mailbox!/server
  local-mailbox-names/server)

(import scheme chicken)
(use
  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
  (only data-structures identity)
  tcp
  (only miscmacros define-parameter while)
  (only moremacros define-warning-parameter)
  tcp-server
  mailbox
  lookup-table-synch
  type-checks
  type-errors
  condition-utils
  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))

;;; Conditions

(: make-remote-mailbox-server-condition (string remote-mailbox-server list (or condition symbol list) -> condition))
;
(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

;;

(: 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 -> *))
;
(define-record-type remote-mailbox-server
  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
  remote-mailbox-server?
  (dctm remote-mailbox-server-dict/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)) )

(: default-remote-mailbox-listen (#!optional (or boolean procedure) -> procedure))
;
(define-warning-parameter default-remote-mailbox-listen tcp-listen remote-mailbox-listener
  ;ugh, automagic identifier injection
  (unless obj (set! obj tcp-listen)) )

(: default-remote-mailbox-auto-create? (#!optional boolean -> boolean))
;
(define-parameter default-remote-mailbox-auto-create? #t identity)

;; Support

(: *local-mailbox-for-server (remote-mailbox-server * boolean -> mailbox))
;
(define (*local-mailbox-for-server rmbs name create?)
  (dict-indempotent-ref!/synch
    (remote-mailbox-server-dict/synch rmbs)
    name
    (lambda (def) (if create? (make-mailbox name) def))) )

(: make-remote-mailbox-server-thunk (remote-mailbox-server #!optional input-port -> procedure))
;
(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
              (*local-mailbox-for-server
                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))
      (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
    ;as
    ex
    ;with
    (void)
    ;in
    (tcp-close (remote-mailbox-server-listener rmbs))
    (thread-join! (remote-mailbox-server-thread rmbs)) ) )

;; Exported

(: make-remote-mailbox-server (#!rest -> remote-mailbox-server))
;
(define (make-remote-mailbox-server
          #!key
          (tcp-port-no (default-remote-mailbox-tcp-port-no))
          (listen (default-remote-mailbox-listen))
          (name (gensym 'remote-mailbox-server:))
          (auto-create? (default-remote-mailbox-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-dict/synch)
        name
        auto-create?
        (deserializer)
        #f #f
        (listen tcp-port-no)
        request-limit
        debug #f))
    (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 ) )

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

;;

(: remote-mailbox-server-run! (remote-mailbox-server -> void))
;
(define (remote-mailbox-server-run! rmbs)
  (*remote-mailbox-server-run!
    (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)) )

(: remote-mailbox-server-start! (remote-mailbox-server -> thread))
;
(define (remote-mailbox-server-start! rmbs)
  (*remote-mailbox-server-start!
    (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)) )

(: remote-mailbox-server-stop! (remote-mailbox-server -> void))
;
(define (remote-mailbox-server-stop! rmbs)
  (*remote-mailbox-server-stop!
    (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)) )

;;

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

(: drop-local-mailbox!-for-server (remote-mailbox-server mailbox-name -> void))
;
(define (drop-local-mailbox!-for-server rmbs name)
  (dict-delete!/synch
    (remote-mailbox-server-dict/synch
      (check-remote-mailbox-server 'drop-local-mailbox!-for-server rmbs))
    (check-mailbox-name 'drop-local-mailbox!-for-server name)) )

(: local-mailbox-names-for-server (remote-mailbox-server -> (list-of string)))
;
(define (local-mailbox-names-for-server rmbs)
  (dict-keys/synch
    (remote-mailbox-server-dict/synch
      (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs))) )

;;; Convenience

(define +rmbs+ #f)
(define +thrd+ #f)

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

(: local-mailbox-server (-> remote-mailbox-server))
;
(define (local-mailbox-server)
  +rmbs+ )

(: local-mailbox-thread (-> thread))
;
(define (local-mailbox-thread)
  +thrd+ )

(: local-mailbox (mailbox-name #!optional * -> mailbox))
;
(define (local-mailbox name #!optional debug)
  (unless +rmbs+ (local-mailbox-start! debug))
  (*local-mailbox-for-server +rmbs+ (check-mailbox-name 'local-mailbox name) #t) )

;;DEPRECATED

(: local-mailbox/server deprecated)
(define local-mailbox/server local-mailbox-for-server)

(: drop-local-mailbox!/server deprecated)
(define drop-local-mailbox!/server drop-local-mailbox!-for-server)

(: local-mailbox-names/server (deprecated local-mailbox-names-for-server))
(define local-mailbox-names/server local-mailbox-names-for-server)

;(: default-remote-mailbox-tcp-port (deprecated default-remote-mailbox-tcp-port-no))

) ;module remote-mailbox-server