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

;; Issues
;;
;; - Currently the client input port is unused.

(module remote-mailbox-client

(;export
  ;;common
  ;parameters
  remote-mailbox-default-tcp-port-no
  remote-mailbox-default-hostname
  ;;client
  ;parameters
  remote-mailbox-default-connect
  ;operations
  make-remote-mailbox
  remote-mailbox?
  remote-mailbox-name
  remote-mailbox-hostname
  remote-mailbox-tcp-port-no
  remote-mailbox-connected?
  drop-remote-mailbox!
  drop-remote-mailboxes!
  remote-mailboxes
  remote-mailbox-send!)

(import scheme
  (chicken base)
  (chicken type)
  (chicken tcp)
  (only (chicken string) conc)
  (only (srfi 18) make-mutex mutex-name)
  (only (srfi 69)
    make-hash-table hash-table-ref/default
    hash-table-set! hash-table-values
    hash-table? hash-table-delete!
    symbol-hash)
  (only moremacros ->boolean define-warning-parameter)
  (only type-errors warning-argument-type)
  mailbox
  synch-open
  (only type-checks check-procedure define-check+error-type)
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)

;;

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

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

(: remote-mailbox-default-connect (#!optional (or boolean procedure) -> procedure))

(: make-remote-mailbox (mailbox-name #!rest -> remote-mailbox))
(: remote-mailbox? (* -> boolean : remote-mailbox))
(: remote-mailbox-connected? (remote-mailbox -> boolean))
(: remote-mailbox-name (remote-mailbox --> mailbox-name))
(: remote-mailbox-hostname (remote-mailbox --> hostname))
(: remote-mailboxes (-> (list-of remote-mailbox)))
(: drop-remote-mailbox! (remote-mailbox -> void))
(: drop-remote-mailboxes! (-> void))
(: remote-mailbox-send! (remote-mailbox * -> void))

(: remote-mailbox-ref (symbol ((or false symbol) -> (or false remote-mailbox)) --> (or false remote-mailbox)))
(: remote-mailbox-delete! (symbol -> void))
(: remote-mailbox-values (-> (list-of remote-mailbox)))

(: make-remote-mailbox-key (mailbox-name hostname tcp-port-no --> symbol))

(: checked-make-remote-mailbox (symbol mailbox-name hostname tcp-port-no procedure -> remote-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))

(: make-hash-table/%synch (#!rest -> mutex))
(: hash-table-values/%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-values)
(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-values/%synch hash-table-values-%synch)
(define hash-table-indempotent-ref!/%synch hash-table-indempotent-ref!-%synch)
(define hash-table-delete!/%synch hash-table-delete!-%synch)

;; Support

(define-record-type remote-mailbox
  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
  *remote-mailbox?
  (name remote-mailbox-name remote-mailbox-name-set!)
  (hstnam remote-mailbox-hostname)
  (prtnum remote-mailbox-tcp-port-no)
  (serializer remote-mailbox-serializer)
  (connect remote-mailbox-connect)
  (mutex remote-mailbox-mutex)
  (input remote-mailbox-input-port remote-mailbox-input-port-set!)
  (output remote-mailbox-output-port remote-mailbox-output-port-set!) )

(define (invalidate-remote-mailbox! rmb)
  (remote-mailbox-name-set! rmb #f) )

(define (valid-remote-mailbox? rmb)
  (->boolean (remote-mailbox-name rmb)) )

(define (remote-mailbox-key rmb)
  (mutex-name (remote-mailbox-mutex rmb)) )

(define-constant EXPECTED-REMOTES 8)

(define remote-mailbox-ref)
(define remote-mailbox-delete!)
(define remote-mailbox-values)
(let ((+remote-mailbox-map+ (make-hash-table/%synch eq? symbol-hash EXPECTED-REMOTES)))
  (set! remote-mailbox-ref (lambda (key f)
    (hash-table-indempotent-ref!/%synch +remote-mailbox-map+ key f) ) )
  (set! remote-mailbox-delete! (lambda (key)
    (hash-table-delete!/%synch +remote-mailbox-map+ key) ) )
  (set! remote-mailbox-values (lambda ()
    (hash-table-values/%synch +remote-mailbox-map+) ) ) )

(define (make-remote-mailbox-key name hostname tcp-port-no)
  (string->symbol (conc name #\@ hostname (if tcp-port-no (conc #\: tcp-port-no) ""))) )

(define (checked-make-remote-mailbox loc name hostname tcp-port-no connect)
  (let* ((tcp-port-no
           (and tcp-port-no (check-tcp-port-no loc tcp-port-no 'tcp-port-no)))
         (key
           (make-remote-mailbox-key
             (check-mailbox-name loc name 'name)
             (check-hostname loc hostname 'hostname)
             tcp-port-no)) )
    (remote-mailbox-ref
      key
      (lambda (def)
        (assert (not def) loc "cannot redefine mailbox" key def)
        (*make-remote-mailbox
          name hostname tcp-port-no
          (serializer)
          (check-procedure loc connect 'connect)
          (make-mutex key)
          #f #f))) ) )

(define (*remote-mailbox-connected? rmb)
  (->boolean (remote-mailbox-output-port rmb)) )

(define (connection/remote-mailbox rmb)
  (if (*remote-mailbox-connected? rmb)
    (remote-mailbox-output-port rmb)
    ;else make a connection
    (let-values (((in out)
                  (let ((connect (remote-mailbox-connect rmb))
                        (tcp-port-no (remote-mailbox-tcp-port-no rmb)) )
                    ;Allow hostname to carry service/portno
                    (if (not tcp-port-no)
                      (connect (remote-mailbox-hostname rmb))
                      (connect (remote-mailbox-hostname rmb) tcp-port-no) ) ) ) )
      (remote-mailbox-input-port-set! rmb in)
      (remote-mailbox-output-port-set! rmb out)
      out ) ) )

(define (close-remote-mailbox-connection! rmb)
  (close-input-port (remote-mailbox-input-port rmb))
  (remote-mailbox-input-port-set! rmb #f)
  (close-output-port (remote-mailbox-output-port rmb))
  (remote-mailbox-output-port-set! rmb #f)
  (invalidate-remote-mailbox! rmb) )

(define (*drop-remote-mailbox! rmb)
  (%record-synch rmb remote-mailbox
    (close-remote-mailbox-connection! rmb)
    (remote-mailbox-delete! (remote-mailbox-key rmb)) ) )

;;; Exported

;; Parameters

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

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

;; Operations

(define (make-remote-mailbox name
          #!key
          (hostname (remote-mailbox-default-hostname))
          (tcp-port-no (remote-mailbox-default-tcp-port-no))
          (connect (remote-mailbox-default-connect)))
  (checked-make-remote-mailbox 'make-remote-mailbox name hostname tcp-port-no connect) )

(define (remote-mailbox? obj)
  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )

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

(define (remote-mailbox-connected? rmb)
  (*remote-mailbox-connected? (check-remote-mailbox 'remote-mailbox-connected? rmb)) )

(define (drop-remote-mailbox! rmb)
  (*drop-remote-mailbox! (check-remote-mailbox 'drop-remote-mailbox! rmb)) )

(define (drop-remote-mailboxes!)
  (for-each (cut *drop-remote-mailbox! <>) (remote-mailbox-values)) )

(define (remote-mailboxes)
  (remote-mailbox-values) )

(define (remote-mailbox-send! rmb val)
  (%record-synch (check-remote-mailbox 'remote-mailbox-send! rmb) remote-mailbox
    (let ((out (connection/remote-mailbox rmb))
          (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
      (parameterize ((serializer (remote-mailbox-serializer rmb)))
        (serialize req out) ) ) ) )

) ;module remote-mailbox-client