;;;; 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
    default-remote-mailbox-serializer
    ; 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
          tcp
          (only srfi-18 make-mutex mutex-name)
          (only data-structures conc)
          (only miscmacros define-parameter)
          s11n
          mailbox
          synch
          lookup-table-synch
          (only type-checks check-procedure define-check+error-type)
          remote-mailbox-common)

  (require-library tcp srfi-18
                   miscmacros s11n mailbox synch lookup-table-synch type-checks
                   remote-mailbox-common)

;;; Utilities

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

;;; Support

(define-record-type remote-mailbox
	(*make-remote-mailbox name hstnam prtnum connect mutex input output)
	*remote-mailbox?
	(name remote-mailbox-name remote-mailbox-name-set!)
	(hstnam remote-mailbox-hostname)
	(prtnum remote-mailbox-tcp-port)
	(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 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-serializer #f
  (lambda (x)
  	(cond ((procedure? x) x)
          ((not x) #f)
          (else (default-remote-mailbox-serializer))) ) )

(define-parameter default-remote-mailbox-connect tcp-connect
  (lambda (x)
  	(cond ((procedure? x) x)
          (else (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 #!optional (serializer (default-remote-mailbox-serializer)))
	(check-remote-mailbox 'remote-mailbox-send! rmb)
	(when serializer (check-procedure 'remote-mailbox serializer 'serializer))
	(record/synch remote-mailbox rmb
		(let ((out (connection/remote-mailbox rmb))
		      (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
			(serialize req out serializer) ) ) )

) ;module remote-mailbox-client