Ignore:
Timestamp:
03/25/17 21:46:49 (2 years ago)
Author:
Kon Lovett
Message:

mv serialize to adapter module

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/remote-mailbox/trunk/remote-mailbox-server.scm

    r19860 r33908  
    99(module remote-mailbox-server
    1010
    11   (;export
    12     ;; Common
    13     ; Parameters
    14     default-remote-mailbox-tcp-port
    15     default-remote-mailbox-hostname
    16     ;; Server
    17     ; Parameters
    18     default-remote-mailbox-deserializer
    19     default-remote-mailbox-listen
    20     default-remote-mailbox-auto-create?
    21     ; Operations
    22     make-remote-mailbox-server
    23     make-remote-mailbox-server-thread
    24     local-mailbox/server
    25     drop-local-mailbox!/server
    26     local-mailbox-names/server
    27     remote-mailbox-server-run!
    28     remote-mailbox-server-start!
    29     ;; Queries
    30     remote-mailbox-server?
    31     remote-mailbox-server-name
    32     remote-mailbox-server-auto-create?
    33     remote-mailbox-server-deserializer
    34     remote-mailbox-server-listener
    35     remote-mailbox-server-request-limit
    36     remote-mailbox-server-debug
    37     ;; Convenience
    38     local-mailbox-server
    39     local-mailbox-thread
    40     local-mailbox-start!
    41     local-mailbox)
    42 
    43   (import
    44     scheme
    45     chicken
    46     (only srfi-18 make-thread thread-start! mutex-name)
    47     (only data-structures identity)
    48     tcp
    49     (only miscmacros define-parameter while)
    50     tcp-server
    51     s11n
    52     mailbox
    53     lookup-table-synch
    54     type-checks
    55     type-errors
    56     condition-utils
    57     remote-mailbox-common)
    58 
    59   (require-library
    60     srfi-18 data-structures tcp
    61     tcp-server s11n mailbox miscmacros lookup-table-synch type-checks
    62     condition-utils
    63     remote-mailbox-common)
     11(;export
     12  ;; Common
     13  ; Parameters
     14  default-remote-mailbox-tcp-port
     15  default-remote-mailbox-hostname
     16  ;; Server
     17  ; Parameters
     18  default-remote-mailbox-listen
     19  default-remote-mailbox-auto-create?
     20  ; Operations
     21  make-remote-mailbox-server
     22  make-remote-mailbox-server-thread
     23  local-mailbox/server
     24  drop-local-mailbox!/server
     25  local-mailbox-names/server
     26  remote-mailbox-server-run!
     27  remote-mailbox-server-start!
     28  remote-mailbox-server-stop!
     29  ;; Queries
     30  remote-mailbox-server?
     31  remote-mailbox-server-name
     32  remote-mailbox-server-auto-create?
     33  remote-mailbox-server-listener
     34  remote-mailbox-server-request-limit
     35  remote-mailbox-server-debug
     36  ;; Convenience
     37  local-mailbox-server
     38  local-mailbox-thread
     39  local-mailbox-start!
     40  local-mailbox)
     41
     42(import scheme chicken)
     43
     44(import
     45  (only srfi-18 make-thread thread-start! mutex-name thread-join!)
     46  (only data-structures identity)
     47  tcp
     48  (only miscmacros define-parameter while)
     49  tcp-server
     50  mailbox
     51  lookup-table-synch
     52  type-checks
     53  type-errors
     54  condition-utils
     55  remote-mailbox-adapter
     56  remote-mailbox-packet
     57  remote-mailbox-common)
     58(require-library
     59  srfi-18 data-structures tcp
     60  tcp-server mailbox miscmacros lookup-table-synch type-checks
     61  condition-utils
     62  remote-mailbox-adapter
     63  remote-mailbox-packet
     64  remote-mailbox-common)
    6465
    6566;;; Conditions
     
    7677
    7778(define (remote-mailbox-server-request-exception rmbs . args)
    78   (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request"  rmbs args 'request)) )
     79  (abort (make-remote-mailbox-server-condition "unknown remote mailbox client request" rmbs args 'request)) )
    7980
    8081;;; Server Side
     
    8384
    8485(define-record-type remote-mailbox-server
    85   (*make-remote-mailbox-server dctm nm autof desrl srvr lstnr rlim dbg thrd)
     86  (*make-remote-mailbox-server dctm nm autof desrl srvr thread lstnr rlim dbg thrd)
    8687  remote-mailbox-server?
    8788  (dctm remote-mailbox-server-dict/synch)
     
    9091  (desrl remote-mailbox-server-deserializer)
    9192  (srvr remote-mailbox-server-tcp-server remote-mailbox-server-tcp-server-set!)
     93  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
    9294  (lstnr remote-mailbox-server-listener)
    9395  (rlim remote-mailbox-server-request-limit)
     
    98100(define-constant default-request-count-limit 10000)
    99101
    100 (define-parameter default-remote-mailbox-deserializer #f
    101   (lambda (x)
    102         (cond
    103           ((procedure? x)   x)
    104       ((not x)          #f)
    105       (else
    106         (warning-argument-type 'default-remote-mailbox-deserializer x 'procedure)
    107         (default-remote-mailbox-deserializer) ) ) ) )
    108 
    109102(define-parameter default-remote-mailbox-listen tcp-listen
    110103  (lambda (x)
    111         (cond
    112           ((procedure? x) x)
     104    (cond
     105      ((procedure? x)
     106        x )
     107      ((not x)
     108        tcp-listen )
    113109      (else
    114110        (warning-argument-type 'default-remote-mailbox-listen x 'procedure)
     
    122118
    123119(define (*local-mailbox/server rmbs name create?)
    124         (dict-indempotent-ref!/synch
     120  (dict-indempotent-ref!/synch
    125121    (remote-mailbox-server-dict/synch rmbs)
    126122    name
    127123    (lambda (def) (if create? (make-mailbox name) def))) )
    128124
    129 (define ((make-remote-mailbox-server-thunk rmbs))
    130   (while (not (eof-object? (peek-char (current-input-port))))
    131     (let ((req (deserialize (current-input-port) (remote-mailbox-server-deserializer rmbs))))
    132       (cond ((eq? (void) req) ) ;ignore void transmissions
    133             ((remote-mailbox-packet? req)
    134               (let* ((nam (remote-mailbox-packet-key req))
    135                      (lmb (*local-mailbox/server rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
    136                 (if lmb (mailbox-send! lmb (remote-mailbox-packet-value req))
    137                     (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
    138             (else
    139               (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
     125(define ((make-remote-mailbox-server-thunk rmbs) #!optional (inp (current-input-port)))
     126  (while (not (eof-object? (peek-char inp)))
     127    (let ((req
     128            (parameterize ((deserializer (remote-mailbox-server-deserializer rmbs)))
     129              (deserialize inp))))
     130      (cond
     131        ((eq? (void) req)
     132          ;ignore void transmissions
     133          )
     134        ((remote-mailbox-packet? req)
     135          (let* ((nam (remote-mailbox-packet-key req))
     136                 (lmb
     137                  (*local-mailbox/server
     138                    rmbs nam (remote-mailbox-server-auto-create? rmbs))) )
     139            (if lmb
     140              (mailbox-send! lmb (remote-mailbox-packet-value req))
     141              (remote-mailbox-server-mailbox-exception rmbs nam)) ) )
     142        (else
     143          (remote-mailbox-server-request-exception rmbs req) ) ) ) ) )
    140144
    141145(define (*remote-mailbox-server-run! rmbs)
    142         ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
     146  ((remote-mailbox-server-tcp-server rmbs) (remote-mailbox-server-debug rmbs)) )
    143147
    144148(define (*make-remote-mailbox-server-thread rmbs)
    145   (make-thread (lambda () (*remote-mailbox-server-run! rmbs)) (remote-mailbox-server-name rmbs)) )
     149  (remote-mailbox-server-thread-set! rmbs
     150    (make-thread
     151      (lambda () (*remote-mailbox-server-run! rmbs))
     152      (remote-mailbox-server-name rmbs)))
     153  (remote-mailbox-server-thread rmbs) )
    146154
    147155(define (*remote-mailbox-server-start! rmbs)
    148         (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     156  (thread-start! (*make-remote-mailbox-server-thread rmbs)) )
     157
     158(define (*remote-mailbox-server-stop! rmbs)
     159  (tcp-close (remote-mailbox-server-listener rmbs))
     160  (handle-exceptions ex
     161     (void)
     162    (thread-join! (remote-mailbox-server-thread rmbs)) ) )
    149163
    150164;; Exported
    151165
    152166(define (make-remote-mailbox-server
    153           #!key (tcp-port (default-remote-mailbox-tcp-port))
    154                 (listen (default-remote-mailbox-listen))
    155                 (deserializer (default-remote-mailbox-deserializer))
    156                 (name (gensym 'remote-mailbox-server:))
    157                 (auto-create? (default-remote-mailbox-auto-create?))
    158                 (request-limit default-request-count-limit)
    159                 debug)
    160         (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
    161         (check-procedure 'make-remote-mailbox-server listen 'listen)
    162         (when deserializer (check-procedure 'make-remote-mailbox-server deserializer 'deserializer))
    163         (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
    164   (let* ((listener (listen tcp-port))
    165          (rmbs (*make-remote-mailbox-server (make-dict/synch) name auto-create?
    166                                             deserializer #f listener request-limit
    167                                             debug #f))
    168          (tcps (make-tcp-server listener
    169                                 (make-remote-mailbox-server-thunk rmbs)
    170                                 request-limit)) )
     167          #!key
     168          (tcp-port (default-remote-mailbox-tcp-port))
     169          (listen (default-remote-mailbox-listen))
     170          (name (gensym 'remote-mailbox-server:))
     171          (auto-create? (default-remote-mailbox-auto-create?))
     172          (request-limit default-request-count-limit)
     173          debug)
     174  (check-tcp-port 'make-remote-mailbox-server tcp-port 'tcp-port)
     175  (check-procedure 'make-remote-mailbox-server listen 'listen)
     176  (check-fixnum 'make-remote-mailbox-server request-limit 'request-limit)
     177  (let* ((rmbs
     178          (*make-remote-mailbox-server
     179            (make-dict/synch)
     180            name
     181            auto-create?
     182            (deserializer)
     183            #f #f
     184            (listen tcp-port)
     185            request-limit
     186            debug #f))
     187         (tcps
     188          (make-tcp-server
     189            (remote-mailbox-server-listener rmbs)
     190            (make-remote-mailbox-server-thunk rmbs)
     191            (remote-mailbox-server-request-limit rmbs))) )
    171192    (remote-mailbox-server-tcp-server-set! rmbs tcps)
    172193    rmbs ) )
    173194
    174195(define (make-remote-mailbox-server-thread rmbs)
    175         (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
     196  (check-remote-mailbox-server 'make-remote-mailbox-server-thread rmbs)
    176197  (*make-remote-mailbox-server-thread rmbs) )
    177198
     
    179200
    180201(define (remote-mailbox-server-run! rmbs)
    181         (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
    182         (*remote-mailbox-server-run! rmbs) )
     202  (check-remote-mailbox-server 'remote-mailbox-server-run! rmbs)
     203  (*remote-mailbox-server-run! rmbs) )
    183204
    184205(define (remote-mailbox-server-start! rmbs)
    185         (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
    186         (*remote-mailbox-server-start! rmbs) )
     206  (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
     207  (*remote-mailbox-server-start! rmbs) )
     208
     209(define (remote-mailbox-server-stop! rmbs)
     210  (check-remote-mailbox-server 'remote-mailbox-server-stop! rmbs)
     211  (*remote-mailbox-server-stop! rmbs) )
    187212
    188213;;
    189214
    190215(define (local-mailbox/server rmbs name #!optional (create? (remote-mailbox-server-auto-create? rmbs)))
    191         (check-remote-mailbox-server 'local-mailbox/server rmbs)
    192         (check-mailbox-name 'local-mailbox/server name)
    193         (*local-mailbox/server rmbs name create?) )
     216  (check-remote-mailbox-server 'local-mailbox/server rmbs)
     217  (check-mailbox-name 'local-mailbox/server name)
     218  (*local-mailbox/server rmbs name create?) )
    194219
    195220(define (drop-local-mailbox!/server rmbs name)
    196         (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
    197         (check-mailbox-name 'drop-local-mailbox!/server name)
    198         (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
     221  (check-remote-mailbox-server 'drop-local-mailbox!/server rmbs)
     222  (check-mailbox-name 'drop-local-mailbox!/server name)
     223  (dict-delete!/synch (remote-mailbox-server-dict/synch rmbs) name) )
    199224
    200225(define (local-mailbox-names/server rmbs)
    201         (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
    202         (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
     226  (check-remote-mailbox-server 'remote-mailbox-server-mailbox-names rmbs)
     227  (dict-keys/synch (remote-mailbox-server-dict/synch rmbs)) )
    203228
    204229;;; Convenience
    205230
    206 (define local-mailbox-start!)
    207 (define local-mailbox-server)
    208 (define local-mailbox-thread)
    209 (define local-mailbox)
    210 (let ((rmbs #f) (thrd #f))
    211 
    212   (set! local-mailbox-start!
    213     (lambda (#!optional debug)
    214       (unless rmbs
    215         (set! rmbs (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
    216         (set! thrd (*remote-mailbox-server-start! rmbs)) ) ) )
    217 
    218   (set! local-mailbox-server (lambda () rmbs))
    219 
    220   (set! local-mailbox-thread (lambda () thrd))
    221 
    222   (set! local-mailbox
    223     (lambda (name #!optional debug)
    224       (check-mailbox-name 'local-mailbox name)
    225       (unless rmbs (local-mailbox-start! debug))
    226       (*local-mailbox/server rmbs name #t) ) ) )
     231(define +rmbs+ #f)
     232(define +thrd+ #f)
     233
     234(define (local-mailbox-start! #!optional debug)
     235  (unless +rmbs+
     236    (set! +rmbs+ (make-remote-mailbox-server #:name 'default-remote-mailbox-server #:debug debug))
     237    (set! +thrd+ (*remote-mailbox-server-start! +rmbs+)) ) )
     238
     239(define (local-mailbox-server)
     240  +rmbs+ )
     241
     242(define (local-mailbox-thread)
     243  +thrd+ )
     244
     245(define (local-mailbox name #!optional debug)
     246  (check-mailbox-name 'local-mailbox name)
     247  (unless +rmbs+ (local-mailbox-start! debug))
     248  (*local-mailbox/server +rmbs+ name #t) )
    227249
    228250) ;module remote-mailbox-server
Note: See TracChangeset for help on using the changeset viewer.