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

;; 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
  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/server
  drop-local-mailbox!/server
  local-mailbox-names/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)

(import scheme chicken)

(import
  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
  (only data-structures identity)
  tcp
  (only miscmacros define-parameter while)
  tcp-server
  mailbox
  lookup-table-synch
  type-checks
  type-errors
  condition-utils
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)
(require-library
  srfi-18 data-structures tcp
  tcp-server mailbox miscmacros lookup-table-synch type-checks
  condition-utils
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)

;;; 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 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) )

;; Parameters

(define-constant default-request-count-limit 10000)

(define-parameter default-remote-mailbox-listen tcp-listen
  (lambda (x)
    (cond
      ((procedure? x)
        x )
      ((not x)
        tcp-listen )
      (else
        (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
        (default-remote-mailbox-listen) ) ) ) )

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

;; Support

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

(define (*local-mailbox/server rmbs name create?)
  (dict-indempotent-ref!/synch
    (remote-mailbox-server-dict/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
                  (*local-mailbox/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)
  (tcp-close (remote-mailbox-server-listener rmbs))
  (handle-exceptions ex
     (void)
    (thread-join! (remote-mailbox-server-thread rmbs)) ) )

;; Exported

(define (make-remote-mailbox-server
          #!key
          (tcp-port (default-remote-mailbox-tcp-port))
          (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 'make-remote-mailbox-server tcp-port 'tcp-port)
  (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)
            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 ) )

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

;;

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

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

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

;;

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

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

(define (local-mailbox-names/server rmbs)
  (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
  (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )

;;; Convenience

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

(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+)) ) )

(define (local-mailbox-server)
  +rmbs+ )

(define (local-mailbox-thread)
  +thrd+ )

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

) ;module remote-mailbox-server