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

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

(module remote-mailbox-client

(;export
  ;; Common
  ; Parameters
  default-remote-mailbox-tcp-port
  default-remote-mailbox-hostname
  ;; Client
  ; Parameters
  default-remote-mailbox-connect
  ; Operations
  remote-mailbox
  remote-mailbox?
  remote-mailbox-name
  remote-mailbox-hostname
  remote-mailbox-tcp-port
  remote-mailbox-connected?
  drop-remote-mailbox!
  drop-remote-mailboxes!
  remote-mailboxes
  remote-mailbox-send!)

(import scheme chicken)

(import
  tcp
  (only srfi-18 make-mutex mutex-name)
  (only data-structures conc)
  (only miscmacros define-parameter)
  mailbox
  synch
  lookup-table-synch
  (only type-checks check-procedure define-check+error-type)
  (only type-errors warning-argument-type)
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)
(require-library
  tcp srfi-18
  miscmacros mailbox synch lookup-table-synch
  type-checks type-errors
  remote-mailbox-adapter
  remote-mailbox-packet
  remote-mailbox-common)

;;; Utilities

(define (->boolean x) (and x #t))

;;; 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)
  (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 +remote-mailbox-key->remote-mailbox+ (make-dict/synch))

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

(define (*remote-mailbox name hostname tcp-port connect)
  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
    (dict-indempotent-ref!/synch +remote-mailbox-key->remote-mailbox+
      key
      (lambda (def)
        (*make-remote-mailbox
          name
          hostname tcp-port
          (serializer) 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 (remote-mailbox-tcp-port rmb)) )
            ; Allow hostname to carry service/portno
            (if (not tcp-port)
              (connect (remote-mailbox-hostname rmb))
              (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
      (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 remote-mailbox rmb
    (close-remote-mailbox-connection! rmb)
    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+
      (remote-mailbox-key rmb)) ) )

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

;;; Exported

;; Parameters

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

;; Operations

(define (remote-mailbox name
          #!key
          (hostname (default-remote-mailbox-hostname))
          (tcp-port (default-remote-mailbox-tcp-port))
          (connect (default-remote-mailbox-connect)))
  (check-mailbox-name 'remote-mailbox name 'name)
  (check-hostname 'remote-mailbox hostname 'hostname)
  (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
  (check-procedure 'remote-mailbox connect 'connect)
  (*remote-mailbox name hostname tcp-port connect) )

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

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

(define (remote-mailboxes)
  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )

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

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

(define (remote-mailbox-send! rmb val)
  (check-remote-mailbox 'remote-mailbox-send! rmb)
  (record/synch remote-mailbox rmb
    (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