Changeset 15945 in project


Ignore:
Timestamp:
09/17/09 22:09:46 (10 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/remote-mailbox/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/remote-mailbox/trunk/remote-mailbox

    r15942 r15945  
    1414                        (subsection "Common Parameters"
    1515
    16                                 (parameter "default-remote-mailbox-port"
     16                                (parameter "default-remote-mailbox-port-number"
    1717                                        (p "The standard port number to establish a remote mailbox connection. "
    18                                         "Defaults to 3001.") )
     18                                        "Defaults to 63001.") )
     19
     20                                (parameter "default-remote-mailbox-host-name"
     21                                        (p "The host name to establish a remote mailbox connection. "
     22                                        "Defaults to \"localhost\".") )
    1923                        )
    2024
    2125                        (subsection "Client Parameters"
    2226
    23                                 (parameter "remote-mailbox-serializer"
     27                                (parameter "default-remote-mailbox-serializer"
    2428                                        (p "The optional serialize failure handler procedure. Must be " (code "#f") " or "
    2529                                        "an arity-1 procedure.") )
    2630
    27                                 (parameter "remote-mailbox-connect-procedure"
     31                                (parameter "default-remote-mailbox-connect-procedure"
    2832                                        (p "The procedure used to establish network connections for a remote mailbox. "
    2933                                        "Defaults to " (code "tcp-connect") " and must be signature-compatible.") )
     
    3236                        (subsection "Client Procedures"
    3337
    34                                 (procedure "(get-remote-mailbox NAME [HOST \"localhost\"] [PORT (default-remote-mailbox-port)])"
     38                                (procedure "(get-remote-mailbox NAME [HOST \"localhost\"] [PORT (default-remote-mailbox-port-number)])"
    3539                                        (p "Returns the remote mailbox object for the specified "
    3640                                        (tt "NAME") ", " (tt "HOST") ", " (code "PORT") ", and " (code "(remote-mailbox-connect-procedure)") ".") )
     
    4246                                        (p "Returns the remote mailbox name.") )
    4347
    44                                 (procedure "(remote-mailbox-host RCH)"
    45                                         (p "Returns the remote mailbox host.") )
     48                                (procedure "(default-remote-mailbox-host-name RCH)"
     49                                        (p "Returns the remote mailbox host name.") )
    4650
    47                                 (procedure "(remote-mailbox-port RCH)"
     51                                (procedure "(remote-mailbox-port-number RCH)"
    4852                                        (p "Returns the remote mailbox port.") )
    4953
     
    6569                        (subsection "Server Parameters"
    6670
    67                                 (parameter "remote-mailbox-deserializer"
     71                                (parameter "default-remote-mailbox-deserializer"
    6872                                        (p "The optional deserialize failure handler procedure. Must be " (code "#f") " or "
    6973                                        "an arity-2 procedure.") )
    7074
    71                                 (parameter "remote-mailbox-listen-procedure"
     75                                (parameter "default-remote-mailbox-listen-procedure"
    7276                                        (p "The procedure used to establish network connections for a remote mailbox. "
    7377                                        "Defaults to " (code "tcp-listen") " and must be signature-compatible.") )
     
    8690                                        (p "Forget the local mailbox.") )
    8791
    88                                 (procedure "(make-remote-mailbox-server [PORT (default-remote-mailbox-port)])"
     92                                (procedure "(make-remote-mailbox-tcp-server [PORT (default-remote-mailbox-port-number)])"
    8993                                        (p "Uses make-tcp-server to create a server procedure on " (code "((remote-mailbox-listen-procedure) PORT)") ". "
    9094                                        "The server threads spawned by this procedure are "
     
    97101                                        "to get remote messages.") )
    98102
    99                                 (procedure "(run-remote-mailbox-server [PORT (default-remote-mailbox-port)])"
     103                                (procedure "(run-remote-mailbox-server [PORT (default-remote-mailbox-port-number)])"
    100104                                        (p "Returns the remote mailbox server thread. Should the server thread "
    101105                                        "not exist it will be created with the specified " (code "((remote-mailbox-listen-procedure) PORT)") " "
     
    120124
    121125* (p "The sender (client) identity is not part of this API.")
    122 
    123 * (p "The use of port 3001 (in the reserved range) is problematic.")
    124126
    125127
  • release/4/remote-mailbox/trunk/remote-mailbox.scm

    r15942 r15945  
    66;; - Currently the client input port is ignored.
    77
    8 (use srfi-18 tcp)
    9 (use tcp-server s11n mailbox miscmacros synch lookup-table misc-extn-record misc-extn-symbol)
    10 
    11 (define-extension remote-mailbox
    12   (export
    13         default-remote-mailbox-port
    14     ;
    15         remote-mailbox-serializer
    16         remote-mailbox-connect-procedure
    17                 get-remote-mailbox
    18                 remote-mailbox?
    19                 remote-mailbox-name
    20                 remote-mailbox-host
    21                 remote-mailbox-port
    22                 remote-mailbox-connected?
    23                 drop-remote-mailbox!
    24                 drop-all-remote-mailboxs!
    25                 remote-mailbox-send!
    26     ;
    27                 remote-mailbox-deserializer
    28         remote-mailbox-listen-procedure
    29                 get-local-mailbox
    30                 drop-local-mailbox!
    31                 make-remote-mailbox-server
    32                 run-remote-mailbox-server
    33                 remote-mailbox-server-listener) )
    34 
    35 (declare
    36    (bound-to-procedure
    37     %remote-mailbox-name) )
     8(module remote-mailbox (export
     9  ;; Common
     10  ; Parameters
     11  default-remote-mailbox-port-number
     12  default-remote-mailbox-host-name
     13  ;; Client
     14  ; Parameters
     15  default-remote-mailbox-connect-procedure
     16  default-remote-mailbox-serializer
     17  default-remote-mailbox-deserializer
     18  default-remote-mailbox-listen-procedure
     19  ; Operations
     20  remote-mailbox
     21  remote-mailbox?
     22  remote-mailbox-name
     23  remote-mailbox-host-name
     24  remote-mailbox-port-number
     25  remote-mailbox-connected?
     26  drop-remote-mailbox!
     27  drop-all-remote-mailboxs!
     28  remote-mailbox-send!
     29  ;; Server
     30  ; Parameters
     31  default-remote-mailbox-deserializer
     32  default-remote-mailbox-listen-procedure
     33  default-remote-mailbox-auto-create
     34  ; Operations
     35  local-mailbox
     36  drop-local-mailbox!
     37  make-remote-mailbox-server
     38  remote-mailbox-server?
     39  remote-mailbox-server-name
     40  remote-mailbox-server-listener
     41  remote-mailbox-server-start
     42  run-remote-mailbox-server)
     43
     44  (import scheme
     45          chicken
     46          (only srfi-13 string-prefix? string-null?)
     47          (srfi-18 make-thread thread-start thread-name thread-specific thread-specific-set!)
     48          tcp
     49          (only miscmacros define-parameter)
     50          tcp-server
     51          s11n
     52          mailbox
     53          synch
     54          lookup-table
     55          type-checks
     56          conditions)
     57         
     58  (require-library srfi-18 tcp
     59                   tcp-server s11n mailbox miscmacros synch lookup-table type-checks conditions)
     60
     61  (declare
     62     (bound-to-procedure
     63      remote-mailbox-name) )
    3864
    3965;;;
    4066
    41 (define (->boolean x)
    42   (and x
    43        #t) )
     67(define (->boolean x) (and x #t))
     68
     69;;; Synchronized Dictionary
     70
     71(define-constant INITIAL-DICT-SIZE 4)
     72
     73(define (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
     74  (make-object/synch (make-dict guess eq?) id) )
    4475
    4576;;;
    4677
    47 (define-inline (tcp-portno? obj)
     78(define mailbox-name? symbol?)
     79
     80(define (port-number? obj)
    4881        (and (fixnum? obj)
    4982             (and (fx< 0 obj) (fx< obj 65536)) ) )
    5083
    51 ;;; Synchronized Dictionary
    52 
    53 (define-constant INITIAL-DICT-SIZE 4)
    54 
    55 (define-inline (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
    56   (make-object/synch (make-dict guess eq?) id) )
    57 
    58 ;;; Local Exceptional Conditions
    59 
    60 (define (make-exn-condition loc msg . args)
    61   (if (null? args)
    62       (make-property-condition 'exn 'location loc 'message msg)
    63       (make-property-condition 'exn 'location loc 'message msg 'arguments args) ) )
     84(define (host-name? obj)
     85  (and (string? obj) (not (string-null? obj))) )
     86
     87;;; Conditions
    6488
    6589(define (make-remote-mailbox-exception loc msg . args)
    66         (make-composite-condition
    67    (apply make-exn-condition loc msg args)
    68          (make-property-condition 'remote-mailbox)) )
     90        (make-exn-condition+ loc msg args 'remote-mailbox) )
    6991
    7092;;; Remote Mailbox Packet
     
    7294(define remote-mailbox-tag 'rmb)
    7395
    74 (define-inline (make-remote-mailbox-packet rmb val)
    75         (vector remote-mailbox-tag (%remote-mailbox-name rmb) val) )
    76 
    77 (define-inline (remote-mailbox-packet-mailbox-tag rmp)
    78         (vector-ref rmp 0) )
    79 
    80 (define-inline (remote-mailbox-packet-mailbox-name rmp)
    81         (vector-ref rmp 1) )
    82 
    83 (define-inline (remote-mailbox-packet-mailbox-value rmp)
    84         (vector-ref rmp 2) )
    85 
    86 (define-inline (remote-mailbox-packet? obj)
     96(define (make-remote-mailbox-packet rmb val)
     97        (vector remote-mailbox-tag (remote-mailbox-name rmb) val) )
     98
     99(define (remote-mailbox-packet-mailbox-tag rmp) (vector-ref rmp 0))
     100
     101(define (remote-mailbox-packet-mailbox-name rmp) (vector-ref rmp 1))
     102
     103(define (remote-mailbox-packet-mailbox-value rmp) (vector-ref rmp 2))
     104
     105(define (remote-mailbox-packet? obj)
    87106        (and (vector? obj)
    88107                         (= 3 (vector-length obj))
     
    91110;;; Communication IP Port
    92111
    93 (define-constant INITIAL-REMOTE-MAILBOX-PORT 3001)
    94 
    95 (define-parameter default-remote-mailbox-port
    96         INITIAL-REMOTE-MAILBOX-PORT
     112(define-parameter default-remote-mailbox-port-number 63001
    97113        (lambda (x)
    98                 (if (tcp-portno? x)
    99         x
    100         (default-remote-mailbox-port)) ) )
     114                (cond ((port-number? x) x)
     115          (else (default-remote-mailbox-port-number) ) ) ) )
     116
     117(define-parameter default-remote-mailbox-host-name "localhost"
     118        (lambda (x)
     119                (cond ((host-name? x) x)
     120          (else (default-remote-mailbox-host-name) ) ) ) )
    101121
    102122;;; Client Side
     
    109129(define fullname->remote-mailbox (make-remote-mailbox-mutex))
    110130
    111 (define (make-remote-mailbox-key name host port)
    112         (conc name #\@ host #\: port) )
    113 
    114 (define-record-type/unsafe-inline-unchecked remote-mailbox
    115         (%make-remote-mailbox name host port connect mutex input output)
    116         %remote-mailbox?
    117         (name %remote-mailbox-name %remote-mailbox-name-set!)
    118         (host %remote-mailbox-host)
    119         (port %remote-mailbox-port)
    120         (connect %remote-mailbox-connect-procedure)
    121         (mutex %remote-mailbox-mutex)
    122         (input %remote-mailbox-input-port %remote-mailbox-input-port-set!)
    123         (output %remote-mailbox-output-port %remote-mailbox-output-port-set!) )
     131(define (make-remote-mailbox-key name host-name port-number)
     132        (conc name #\@ host-name #\: port-number) )
     133
     134(define-record-type remote-mailbox
     135        (*make-remote-mailbox name hstnam prtnum connect mutex input output)
     136        *remote-mailbox?
     137        (name remote-mailbox-name remote-mailbox-name-set!)
     138        (hstnam remote-mailbox-host-name)
     139        (prtnum remote-mailbox-port-number)
     140        (connect remote-mailbox-connect-procedure)
     141        (mutex remote-mailbox-mutex)
     142        (input remote-mailbox-input-port-number remote-mailbox-input-port-number-set!)
     143        (output remote-mailbox-output-port-number remote-mailbox-output-port-number-set!) )
    124144
    125145(define (invalidate-remote-mailbox! rmb)
    126         (%remote-mailbox-name-set! rmb #f) )
     146        (remote-mailbox-name-set! rmb #f) )
    127147
    128148(define (valid-remote-mailbox? rmb)
    129         (->boolean (%remote-mailbox-name rmb)) )
    130 
    131 (define (check-mailbox-name loc obj)
    132         (unless (symbol? obj)
    133                 (error loc "mailbox name not a symbol" obj)) )
    134 
    135 (define (check-host loc obj)
    136         (unless (string? obj)
    137                 (error loc "host not a string" obj)) )
    138 
    139 (define (check-port loc obj)
    140         (unless (tcp-portno? obj)
    141                 (error loc "invalid port" obj)) )
    142 
    143 (define (check-remote-mailbox loc rmb)
    144         (unless (%remote-mailbox? rmb)
    145                 (error loc "not a remote mailbox" rmb)) )
    146 
    147 (define (check-valid-remote-mailbox loc rmb)
    148         (check-remote-mailbox loc rmb)
    149         (unless (valid-remote-mailbox? rmb)
    150                 (error loc "not a valid remote mailbox" rmb)) )
     149        (->boolean (remote-mailbox-name rmb)) )
     150
     151;;
     152
     153(define-check+error-type mailbox-name)
     154(define-check+error-type host-name)
     155(define-check+error-type port-number)
     156(define-check+error-type remote-mailbox)
     157
     158;;
    151159
    152160(define (get-connection rmb)
    153         (let ((out (%remote-mailbox-output-port rmb)))
    154                 (if out
    155         ; then we have a connection
    156         (values (%remote-mailbox-input-port rmb) out)
     161        (let ((out (remote-mailbox-output-port-number rmb)))
     162    ; existing connection?
     163                (if out (values (remote-mailbox-input-port-number rmb) out)
    157164        ; else make a connection
    158165        (let-values (((in out)
    159                       ((%remote-mailbox-connect-procedure rmb)
    160                        (%remote-mailbox-host rmb)
    161                        (%remote-mailbox-port rmb))))
    162           (%remote-mailbox-output-port-set! rmb out)
    163           (%remote-mailbox-input-port-set! rmb in)
     166                      ((remote-mailbox-connect-procedure rmb)
     167                       (remote-mailbox-host-name rmb)
     168                       (remote-mailbox-port-number rmb))))
     169          (remote-mailbox-output-port-number-set! rmb out)
     170          (remote-mailbox-input-port-number-set! rmb in)
    164171          (values in out) )) ) )
    165172
    166173(define (close-remote-mailbox-connection! rmb)
    167         (close-input-port (%remote-mailbox-input-port rmb))
    168         (close-output-port (%remote-mailbox-output-port rmb))
    169         (%remote-mailbox-output-port-set! rmb #f)
    170         (%remote-mailbox-input-port-set! rmb #f)
     174        (close-input-port-number (remote-mailbox-input-port-number rmb))
     175        (close-output-port-number (remote-mailbox-output-port-number rmb))
     176        (remote-mailbox-output-port-number-set! rmb #f)
     177        (remote-mailbox-input-port-number-set! rmb #f)
    171178        (invalidate-remote-mailbox! rmb) )
    172179
     
    175182        (dict-for-each n->o
    176183         (lambda (key rmb)
    177                    (synch (%remote-mailbox-mutex rmb)
     184                   (synch (remote-mailbox-mutex rmb)
    178185             (close-remote-mailbox-connection! rmb) ) ) ) ) )
    179186
     
    182189;; Parameters
    183190
    184 (define-parameter remote-mailbox-serializer
    185   #f
     191(define-parameter default-remote-mailbox-serializer #f
    186192  (lambda (x)
    187193        (cond ((procedure? x) x)
    188194          ((not x) #f)
    189           (else (remote-mailbox-serializer))) ) )
    190 
    191 (define-parameter remote-mailbox-connect-procedure
    192   tcp-connect
    193   (lambda (x)
    194         (if (procedure? x)
    195         x
    196         (remote-mailbox-connect-procedure)) ) )
     195          (else (default-remote-mailbox-serializer))) ) )
     196
     197(define-parameter default-remote-mailbox-connect-procedure tcp-connect
     198  (lambda (x)
     199        (cond ((procedure? x) x)
     200          (else (default-remote-mailbox-connect-procedure) ) ) ) )
    197201
    198202;; Operations
    199203
    200 (define (get-remote-mailbox name #!optional (host "localhost") (port (default-remote-mailbox-port)))
    201         (check-mailbox-name 'get-remote-mailbox name)
    202         (check-host 'get-remote-mailbox host)
    203         (check-port 'get-remote-mailbox port)
    204         (let ((key (make-remote-mailbox-key name host port)))
     204(define (remote-mailbox name #!optional (host-name (default-remote-mailbox-host-name))
     205                                        (port-number (default-remote-mailbox-port-number))
     206                                        (connect (default-remote-mailbox-connect-procedure)))
     207        (check-mailbox-name 'remote-mailbox name)
     208        (check-host-name 'remote-mailbox host-name)
     209        (check-port-number 'remote-mailbox port-number)
     210        (check-procedure 'remote-mailbox connect)
     211        (let ((key (make-remote-mailbox-key name host-name port-number)))
    205212                (%let/synch ((n->o fullname->remote-mailbox))
    206213                        (or (dict-ref n->o key)
    207                                         (let ((rmb (%make-remote-mailbox name host port
    208                                                                          (remote-mailbox-connect-procedure)
     214                                        (let ((rmb (*make-remote-mailbox name host-name port-number
     215                                                                         connect
    209216                                                                         (make-mutex key) #f #f)))
    210217                                                (dict-set! n->o key rmb)
     
    212219
    213220(define (remote-mailbox? obj)
    214         (and (%remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    215 
    216 (define (remote-mailbox-name rmb)
    217         (check-remote-mailbox 'remote-mailbox-name rmb)
    218         (%remote-mailbox-name rmb) )
    219 
    220 (define (remote-mailbox-host rmb)
    221         (check-remote-mailbox 'remote-mailbox-host rmb)
    222         (%remote-mailbox-host rmb) )
    223 
    224 (define (remote-mailbox-port rmb)
    225         (check-remote-mailbox 'remote-mailbox-port rmb)
    226         (%remote-mailbox-port rmb) )
     221        (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    227222
    228223(define (remote-mailbox-connected? rmb)
    229224        (check-remote-mailbox 'remote-mailbox-connected? rmb)
    230         (->boolean (%remote-mailbox-output-port rmb)) )
     225        (->boolean (remote-mailbox-output-port-number rmb)) )
    231226
    232227(define (drop-remote-mailbox! rmb)
    233         (check-valid-remote-mailbox 'drop-remote-mailbox! rmb)
    234         (let ((mutex (%remote-mailbox-mutex rmb)))
     228        (check-remote-mailbox 'drop-remote-mailbox! rmb)
     229        (let ((mutex (remote-mailbox-mutex rmb)))
    235230                (synch mutex
    236231                        (close-remote-mailbox-connection! rmb)
     
    242237        (set! fullname->remote-mailbox (make-remote-mailbox-mutex)) )
    243238
    244 (define (remote-mailbox-send! rmb obj)
    245         (check-valid-remote-mailbox 'remote-mailbox-send! rmb)
    246         (synch (%remote-mailbox-mutex rmb)
     239(define (remote-mailbox-send! rmb obj #!optional (serializer (default-remote-mailbox-serializer)))
     240        (check-remote-mailbox 'remote-mailbox-send! rmb)
     241        (synch (remote-mailbox-mutex rmb)
    247242                (let-values (((in out) (get-connection rmb)))
    248                         (serialize (make-remote-mailbox-packet rmb obj) out (remote-mailbox-serializer)) ) ) )
     243                        (serialize (make-remote-mailbox-packet rmb obj) out serializer) ) ) )
    249244
    250245;;; Server Side
     
    252247;; Parameters
    253248
    254 (define-parameter remote-mailbox-deserializer
    255   #f
     249(define-parameter default-remote-mailbox-deserializer #f
    256250  (lambda (x)
    257251        (cond ((procedure? x)   x)
    258252          ((not x)          #f)
    259           (else             (remote-mailbox-deserializer))) ) )
    260 
    261 (define-parameter remote-mailbox-listen-procedure
    262   tcp-listen
    263   (lambda (x)
    264         (if (procedure? x)
    265         x
    266         (remote-mailbox-listen-procedure)) ) )
     253          (else
     254            (default-remote-mailbox-deserializer) ) ) ) )
     255
     256(define-parameter default-remote-mailbox-listen-procedure tcp-listen
     257  (lambda (x)
     258        (cond ((procedure? x) x)
     259          (else
     260            (default-remote-mailbox-listen-procedure) ) ) ) )
     261
     262(define-parameter default-remote-mailbox-auto-create #t
     263  (lambda (x)
     264    x ) )
    267265
    268266;; Support
    269267
    270 (define (remote-mailbox-server)
    271         (let ((req (deserialize (current-input-port) (remote-mailbox-deserializer))))
    272                 (unless (undefined? req)
    273                         (cond ((remote-mailbox-packet? req)
     268(define ((make-remote-mailbox-server-thunk deserializer auto-create?))
     269  (let forever ()
     270    (let ((req (deserialize (current-input-port) deserializer)))
     271      (cond ((eq? (void) req) )
     272            ((remote-mailbox-packet? req)
    274273              (mailbox-send!
    275                (get-local-mailbox (remote-mailbox-packet-mailbox-name req) #t)
     274               (local-mailbox (remote-mailbox-packet-mailbox-name req) auto-create?)
    276275               (remote-mailbox-packet-mailbox-value req)))
    277276            (else
    278277              (signal
    279                (make-remote-mailbox-exception 'remote-mailbox-server
    280                 "request from remote mailbox client not understood"
    281                 req))))) )
    282                 (remote-mailbox-server) )
    283 
    284 (define (%make-remote-mailbox-server listener)
    285         (make-tcp-server listener remote-mailbox-server) )
     278               (make-remote-mailbox-exception
     279                'remote-mailbox-server
     280                "unknown remote mailbox client request" req)) ) ) )
     281    (forever) ) )
     282
     283(define (make-remote-mailbox-tcp-server listener deserializer)
     284        (make-tcp-server listener (make-remote-mailbox-server-thunk deserializer)) )
    286285
    287286(define name->mailbox (make-dict-unique/synch 'name->mailbox))
    288287
     288(define-check+error-type remote-mailbox-server)
     289
    289290;; Exported
    290291
    291 (define (get-local-mailbox name #!optional (create? #t))
    292         (check-mailbox-name 'get-local-mailbox name)
     292(define (local-mailbox name #!optional (create? #f))
     293        (check-mailbox-name 'local-mailbox name)
    293294        (%let/synch ((n->o name->mailbox))
    294295                (or (dict-ref n->o name)
     
    302303                (dict-delete! n->o name) ) )
    303304
    304 (define (make-remote-mailbox-server #!optional (port (default-remote-mailbox-port)))
    305         (check-port 'make-remote-mailbox-server port)
    306         (%make-remote-mailbox-server ((remote-mailbox-listen-procedure) port)) )
     305(define (local-mailbox-names)
     306        (%let/synch ((n->o name->mailbox))
     307    (dict-keys n->o) ) )
     308
     309(define-record-type remote-mailbox-server
     310  (*make-remote-mailbox-server thread listener)
     311  remote-mailbox-server?
     312  (thread remote-mailbox-server-thread)
     313  (listener remote-mailbox-server-listener) )
     314
     315(define (remote-mailbox-server-name server)
     316  (thread-name (remote-mailbox-server-thread server)) )
     317
     318(define (make-remote-mailbox-server
     319          #!key (port-number (default-remote-mailbox-port-number))
     320                (listen (default-remote-mailbox-listen-procedure))
     321                (deserializer (default-remote-mailbox-deserializer))
     322                (name (gensym 'remote-mailbox-server:))
     323                (auto-create? (default-remote-mailbox-auto-create))
     324                debug?)
     325  (let* ((listener (listen port-number))
     326         (tcp-server (make-remote-mailbox-tcp-server listener deserializer auto-create?))
     327         (server-thunk (if debug? (lambda () (tcp-server #t)) tcp-server))
     328    (*make-remote-mailbox-server (make-thread server-thunk name) listener) ) ) )
     329
     330(define (remote-mailbox-server-start! server)
     331        (check-remote-mailbox-server 'remote-mailbox-server-listener server)
     332  (thread-start! (remote-mailbox-server-thread server)) )
    307333
    308334(define run-remote-mailbox-server
    309         (let ((server #f))
    310                 (lambda (#!optional (port (default-remote-mailbox-port)))
    311                         (unless server
    312                                 (check-port 'run-remote-mailbox-server port)
    313                                 (let ((listener ((remote-mailbox-listen-procedure) port)))
    314                                         (set! server
    315                                                     (make-thread
    316                                                            (cute (%make-remote-mailbox-server listener) "remote-mailbox-server")
    317                                                            'remote-mailbox-server))
    318                                         (thread-specific-set! server listener)
    319                                         (thread-start! server)))
    320                         server) ) )
    321 
    322 (define (remote-mailbox-server-listener server)
    323         (unless (and (thread? server) (eq? 'remote-mailbox-server (thread-name)))
    324                 (error 'remote-mailbox-server-listener "not a server thread" server))
    325         (thread-specific server) )
     335  (let ((server #f))
     336    (lambda (#!key (port-number (default-remote-mailbox-port-number))
     337                   (listen (default-remote-mailbox-listen-procedure))
     338                   (deserializer (default-remote-mailbox-deserializer))
     339                   (auto-create? (default-remote-mailbox-auto-create))
     340                   debug?)
     341      (or server
     342          (begin
     343            (set! server
     344                  (make-remote-mailbox-server
     345                    #:port-number port-number
     346                    #:listen listen
     347                    #:deserializer deserializer
     348                    #:auto-create? auto-create?
     349                    #:debug? debug?))
     350            (remote-mailbox-server-start! server)
     351            server ) ) ) ) )
     352
     353) ;module remote-mailbox
     354
Note: See TracChangeset for help on using the changeset viewer.