#|-------------------- 2.0.1 |# "./remote-mailbox-client.scm" 5679
;;;; 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)
    (only type-errors warning-argument-type)
    remote-mailbox-common)

  (require-library
    tcp srfi-18
    miscmacros s11n mailbox synch lookup-table-synch
    type-checks type-errors
    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
        (warning-argument-type 'default-remote-mailbox-serializer x 'procedure)
        (default-remote-mailbox-serializer))) ) )

(define-parameter default-remote-mailbox-connect tcp-connect
  (lambda (x)
  	(cond
  	  ((procedure? x) x)
      (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 #!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


#|-------------------- 2.0.1 |# "./remote-mailbox-common.scm" 1769
;;;; remote-mailbox-common.scm
;;;; Kon Lovett, Sep '09

(module remote-mailbox-common

  (;export
    ;;
    mailbox-name?
    tcp-port?
    hostname?
    error-mailbox-name
    error-tcp-port
    error-hostname
    check-mailbox-name
    check-tcp-port
    check-hostname
    ;;
    make-remote-mailbox-packet
    remote-mailbox-packet?
    remote-mailbox-packet-key
    remote-mailbox-packet-value
    ;;
    default-remote-mailbox-tcp-port
    default-remote-mailbox-hostname)

  (import
    scheme
    chicken
    (only srfi-13 string-null?)
    (only miscmacros define-parameter)
    (only type-checks define-check+error-type))

  (require-library srfi-13 miscmacros type-checks)

;;;

(define mailbox-name? symbol?)

(define (tcp-port? obj) (and (fixnum? obj) (and (fx< 0 obj) (fx< obj 65536))))

(define (hostname? obj) (and (string? obj) (not (string-null? obj))))

;;;

(define-check+error-type mailbox-name)
(define-check+error-type hostname)
(define-check+error-type tcp-port)

;;; Remote Mailbox Packet

(define +remote-mailbox-tag+ 'rmbtag)

(define (make-remote-mailbox-packet key val) (vector +remote-mailbox-tag+ key val))

(define (remote-mailbox-packet? obj)
	(and (vector? obj)
			 (= 3 (vector-length obj))
			 (eq? +remote-mailbox-tag+ (vector-ref obj 0))) )

(define (remote-mailbox-packet-key rmp) (vector-ref rmp 1))

(define (remote-mailbox-packet-value rmp) (vector-ref rmp 2))

;;; Parameters

(define-parameter default-remote-mailbox-tcp-port 63001
	(lambda (x)
		(cond ((tcp-port? x) x)
          (else (default-remote-mailbox-tcp-port) ) ) ) )

(define-parameter default-remote-mailbox-hostname "localhost"
	(lambda (x)
		(cond ((hostname? x) x)
          (else (default-remote-mailbox-hostname) ) ) ) )

) ;module remote-mailbox-common


#|-------------------- 2.0.1 |# "./remote-mailbox-server.scm" 7746
;;;; 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-deserializer
    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!
    ;; Queries
    remote-mailbox-server?
    remote-mailbox-server-name
    remote-mailbox-server-auto-create?
    remote-mailbox-server-deserializer
    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
    (only srfi-18 make-thread thread-start! mutex-name)
    (only data-structures identity)
    tcp
    (only miscmacros define-parameter while)
    tcp-server
    s11n
    mailbox
    lookup-table-synch
    type-checks
    type-errors
    condition-utils
    remote-mailbox-common)

  (require-library
    srfi-18 data-structures tcp
    tcp-server s11n mailbox miscmacros lookup-table-synch type-checks
    condition-utils
    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 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!)
  (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-deserializer #f
  (lambda (x)
  	(cond
  	  ((procedure? x)   x)
      ((not x)          #f)
      (else
        (warning-argument-type 'default-remote-mailbox-deserializer x 'procedure)
        (default-remote-mailbox-deserializer) ) ) ) )

(define-parameter default-remote-mailbox-listen tcp-listen
  (lambda (x)
  	(cond
  	  ((procedure? x) x)
      (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))
  (while (not (eof-object? (peek-char (current-input-port))))
    (let ((req (deserialize (current-input-port) (remote-mailbox-server-deserializer rmbs))))
      (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)
  (make-thread (lambda () (*remote-mailbox-server-run! rmbs)) (remote-mailbox-server-name rmbs)) )

(define (*remote-mailbox-server-start! rmbs)
	(thread-start! (*make-remote-mailbox-server-thread rmbs)) )

;; Exported

(define (make-remote-mailbox-server
          #!key (tcp-port (default-remote-mailbox-tcp-port))
                (listen (default-remote-mailbox-listen))
                (deserializer (default-remote-mailbox-deserializer))
                (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)
	(when deserializer (check-procedure 'make-remote-mailbox-server deserializer 'deserializer))
	(check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
  (let* ((listener (listen tcp-port))
         (rmbs (*make-remote-mailbox-server (make-dict/synch) name auto-create?
                                            deserializer #f listener request-limit
                                            debug #f))
         (tcps (make-tcp-server listener
                                (make-remote-mailbox-server-thunk rmbs)
                                request-limit)) )
    (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 (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 local-mailbox-start!)
(define local-mailbox-server)
(define local-mailbox-thread)
(define local-mailbox)
(let ((rmbs #f) (thrd #f))

  (set! local-mailbox-start!
    (lambda (#!optional debug)
      (unless rmbs
        (set! rmbs (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
        (set! thrd (*remote-mailbox-server-start! rmbs)) ) ) )

  (set! local-mailbox-server (lambda () rmbs))

  (set! local-mailbox-thread (lambda () thrd))

  (set! local-mailbox
    (lambda (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

#|-------------------- 2.0.1 |# "./remote-mailbox.meta" 451
;;;; "remote-mailbox.meta  -*- Hen -*-

((egg "remote-mailbox.egg")
 (category net)
 (author "[[kon lovett]]")
 (license "BSD")
 (doc-from-wiki)
 (synopsis "Remote Mailbox")
 (needs setup-helper tcp-server s11n mailbox miscmacros lookup-table check-errors synch)
 (files "remote-mailbox.meta" "remote-mailbox-client.scm" "remote-mailbox.setup" "remote-mailbox-common.scm" "remote-mailbox-server.scm" "tests/run.scm" "tests/remote-mailbox-test.scm") )

#|-------------------- 2.0.1 |# "./remote-mailbox.setup" 1010
;;;; "remote-mailbox.setup  -*- Hen -*-

(include "setup-helper")

(verify-extension-name "remote-mailbox")

(required-extension-version
  "miscmacros"              "2.91"
  "s11n"                    "0.9.3"
  "mailbox"                 "2.1.2"
  "tcp-server"              "1.2"
  "check-errors"            "1.12.0"
  "synch"                   "2.1.1"
  "lookup-table"            "1.13.1")

(setup-shared-extension-module 'remote-mailbox-common (extension-version "2.0.1")
  #:compile-options '(
    -scrutinize
    -fixnum-arithmetic
    -O3 -d1
    -no-procedure-checks))

(setup-shared-extension-module 'remote-mailbox-client (extension-version "2.0.1")
  #:compile-options '(
    -scrutinize
    -fixnum-arithmetic
    -O3 -d1
    -no-procedure-checks))

(setup-shared-extension-module 'remote-mailbox-server (extension-version "2.0.1")
  #:compile-options '(
    -scrutinize
    -fixnum-arithmetic
    -O3 -d1
    -no-procedure-checks))

(install-extension-tag 'remote-mailbox (extension-version "2.0.1"))