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

(module remote-mailbox-common

(;export
  ;
  mailbox-name? check-mailbox-name error-mailbox-name
  tcp-port-no? check-tcp-port-no error-tcp-port-no
  expected-size? check-expected-size error-expected-size
  hostname? check-hostname error-hostname
  ;
  remote-mailbox-default-tcp-port-no
  remote-mailbox-default-expected-size
  remote-mailbox-default-hostname
  ;
  make-symbol-map
  symbol-map-ref
  symbol-map-delete!
  symbol-map-values)

(import scheme
  (chicken base)
  (chicken type)
  (chicken process-context)
  (only (srfi 13) string-null?)
  (only llrb-tree string-make-table string-table-ref/default
                  string-table-set! string-table-fold
                  string-table? string-table-delete!)
  synch-open
  (only moremacros define-warning-parameter)
  (only type-errors-basic warning-argument-type)
  (only type-checks-basic define-check+error-type)
  (only (check-errors sys) check-procedure))

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

(: mailbox-name? (* -> boolean : mailbox-name))
(: tcp-port-no? (* -> boolean : tcp-port-no))
(: hostname? (* -> boolean : hostname))
(: remote-mailbox-default-tcp-port-no (#!optional (or false fixnum) -> fixnum))
(: remote-mailbox-default-expected-size (#!optional (or false fixnum) -> fixnum))
(: remote-mailbox-default-hostname (#!optional (or false string) -> string))

(: make-symbol-map (-> symbol-map))
(: symbol-map-ref (symbol-map symbol ((or false symbol) -> *) -> *))
(: symbol-map-delete! (symbol-map symbol -> void))
(: symbol-map-values (symbol-map -> list))

;;;

(define-constant DEFAULT-TCP-PORT-NO 63001)
(define-constant DEFAULT-HOSTNAME "localhost")
(define-constant DEFAULT-EXPECTED 8)

(define *environment-variable-tcp-port-no* (get-environment-variable "REMOTE_MAILBOX_TCP_PORT"))
(define *environment-variable-expected* (get-environment-variable "REMOTE_MAILBOX_EXPECTED"))
(define *environment-variable-hostname* (get-environment-variable "REMOTE_MAILBOX_HOSTNAME"))

(define *tcp-port-no*
  (if *environment-variable-tcp-port-no* (string->number *environment-variable-tcp-port-no*)
      DEFAULT-TCP-PORT-NO))
(define *expected-size*
  (if *environment-variable-expected* (string->number *environment-variable-expected*)
      DEFAULT-EXPECTED))
(define *hostname*
  (or *environment-variable-hostname* DEFAULT-HOSTNAME))

;;

(define mailbox-name? symbol?)

(define (tcp-port-no? obj)
  (and (fixnum? obj)
       (and (< 0 obj) (<= obj 65535))) )

(define (expected-size? obj)
  (and (fixnum? obj)
       (< 0 obj)) )

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

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

;; Parameters

(define (remote-mailbox-tcp-port-no? x) (or (not x) (tcp-port-no? x)))
(define (remote-mailbox-expected-size? x) (or (not x) (expected-size? x)))
(define (remote-mailbox-hostname? x) (or (not x) (hostname? x)))

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

(define-warning-parameter remote-mailbox-default-expected-size *expected-size* remote-mailbox-expected-size
  ;ugh, automagic identifier injection
  (unless obj (set! obj *expected-size*)) )

(define-warning-parameter remote-mailbox-default-hostname *hostname* remote-mailbox-hostname
  ;ugh, automagic identifier injection
  (unless obj (set! obj *hostname*)) )

;; Utilities

;FIXME symbol-table has no fold!

(define-check+error-type string-table)

(define (string-table-indempotent-ref! tb key f . opts)
  (check-string-table 'string-table-indempotent-ref! tb)
  (check-procedure 'string-table-indempotent-ref! f)
  (let ((def (optional opts #f)))
    (let ((val (string-table-ref/default tb key def)))
      (if (not (eq? def val)) val
          (let ((val (f def)))
            (if (eq? def val) def
                (begin (string-table-set! tb key val) val)))))))

(define (string-table-values tb)
  (string-table-fold tb (lambda (key val lis) (cons val lis)) '()) )

(define-constructor-%synch string-make-table)
(define-operation-%synch string-table-values)
(define-operation-%synch string-table-indempotent-ref!)
(define-operation-%synch string-table-delete!)

;;

(define (make-symbol-map)
  (string-make-table-%synch) )

(define (symbol-map-ref sm key f)
  (string-table-indempotent-ref!-%synch sm (symbol->string key) f) )

(define (symbol-map-delete! sm key)
  (string-table-delete!-%synch sm (symbol->string key)) )

(define (symbol-map-values sm)
  (string-table-values-%synch sm) )

) ;module remote-mailbox-common