;;;; 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-expected-size
  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-mailboxes
  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)

(import scheme
  (chicken base)
  (chicken type)
  (chicken condition)
  (chicken tcp)
  (only (srfi 18) mutex-name make-thread thread-start!
                  thread-join! thread-terminate!)
  (only miscmacros define-parameter while)
  (only moremacros define-warning-parameter)
  tcp-server
  mailbox
  (only type-checks-basic define-check+error-type)
  (only (check-errors sys) check-fixnum check-procedure)
  exn-condition
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)

(include-relative "remote-mailbox.types")

(: 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 -> symbol))
(: 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 false 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-mailboxes (remote-mailbox-server -> (list-of mailbox)))

(: remote-mailbox-service (mailbox-name #!optional boolean * -> mailbox))
(: remote-mailbox-service-info (-> remote-mailbox-server thread))
(: remote-mailbox-service-stop! (-> void))

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

;;; 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 sm nm autof desrl srvr thread lstnr rlim dbg)
  remote-mailbox-server?
  ;FIXME hide server-local-mailbox-map impl details
  (sm remote-mailbox-server-symbol-map)
  (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?)
  (symbol-map-ref (remote-mailbox-server-symbol-map 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 exn
    (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)) ) )

(define (checked-remote-mailbox-server-symbol-map loc rmbs)
  (remote-mailbox-server-symbol-map (check-remote-mailbox-server loc 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)
  (check-procedure 'make-remote-mailbox-server listen)
  (check-fixnum 'make-remote-mailbox-server request-limit)
  (let* ((rmbs (*make-remote-mailbox-server (make-symbol-map)
                                            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)
  (symbol-map-delete!
    (checked-remote-mailbox-server-symbol-map 'drop-server-local-mailbox! rmbs)
    (check-mailbox-name 'drop-server-local-mailbox! name)) )

(define (server-local-mailboxes rmbs)
  (symbol-map-values
    (checked-remote-mailbox-server-symbol-map 'server-local-mailboxes rmbs)) )

) ;module remote-mailbox-server