Changeset 15957 in project


Ignore:
Timestamp:
09/19/09 02:02:06 (10 years ago)
Author:
Kon Lovett
Message:

Save

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

Legend:

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

    r15945 r15957  
    88== Documentation
    99
    10                         (p "Purports to provide an API for sending and receiving remote messages. "
    11                         "This egg attempts to duplicate the mailbox egg send semantics across an "
    12                         "IP connection.")
    13 
    14                         (subsection "Common Parameters"
    15 
    16                                 (parameter "default-remote-mailbox-port-number"
    17                                         (p "The standard port number to establish a remote mailbox connection. "
    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\".") )
    23                         )
    24 
    25                         (subsection "Client Parameters"
    26 
    27                                 (parameter "default-remote-mailbox-serializer"
    28                                         (p "The optional serialize failure handler procedure. Must be " (code "#f") " or "
    29                                         "an arity-1 procedure.") )
    30 
    31                                 (parameter "default-remote-mailbox-connect-procedure"
    32                                         (p "The procedure used to establish network connections for a remote mailbox. "
    33                                         "Defaults to " (code "tcp-connect") " and must be signature-compatible.") )
    34                         )
    35 
    36                         (subsection "Client Procedures"
    37 
    38                                 (procedure "(get-remote-mailbox NAME [HOST \"localhost\"] [PORT (default-remote-mailbox-port-number)])"
    39                                         (p "Returns the remote mailbox object for the specified "
    40                                         (tt "NAME") ", " (tt "HOST") ", " (code "PORT") ", and " (code "(remote-mailbox-connect-procedure)") ".") )
    41 
    42                                 (procedure "(remote-mailbox? OBJECT)"
    43                                         (p "Is the " (tt "OBJECT") " a valid remote mailbox?") )
    44 
    45                                 (procedure "(remote-mailbox-name RCH)"
    46                                         (p "Returns the remote mailbox name.") )
    47 
    48                                 (procedure "(default-remote-mailbox-host-name RCH)"
    49                                         (p "Returns the remote mailbox host name.") )
    50 
    51                                 (procedure "(remote-mailbox-port-number RCH)"
    52                                         (p "Returns the remote mailbox port.") )
    53 
    54                                 (procedure "(remote-mailbox-connected? RCH)"
    55                                         (p "Is the remote mailbox connected? (Has this remote mailbox been used?)") )
    56 
    57                                 (procedure "(drop-remote-mailbox! RCH)"
    58                                         (p "Invalidate and forget the remote mailbox.") )
    59 
    60                                 (procedure "(remote-mailbox-send! RCH OBJECT)"
    61                                         (p "Transmit the " (tt "OBJECT") " to the remote mailbox, using the "
    62                                         (code "(remote-mailbox-serializer)") ".") )
    63 
    64                                 (procedure "(drop-all-remote-mailboxs!)"
    65                                         (p "Invalidate and forget all the remote mailboxs. Performs a reset to the "
    66                                         "initial state.") )
    67                         )
    68 
    69                         (subsection "Server Parameters"
    70 
    71                                 (parameter "default-remote-mailbox-deserializer"
    72                                         (p "The optional deserialize failure handler procedure. Must be " (code "#f") " or "
    73                                         "an arity-2 procedure.") )
    74 
    75                                 (parameter "default-remote-mailbox-listen-procedure"
    76                                         (p "The procedure used to establish network connections for a remote mailbox. "
    77                                         "Defaults to " (code "tcp-listen") " and must be signature-compatible.") )
    78                         )
    79 
    80                         (subsection "Server Procedures"
    81 
    82                                 (procedure "(get-local-mailbox NAME [CREATE? #t])"
    83                                         (p "Returns the local mailbox (a mailbox object as returned by the "
    84                                         "procedure 'make-mailbox') for " (tt "NAME") ". "
    85                                         "Should the mailbox not exist it will be created when the " (tt "CREATE?") " "
    86                                         "flag is " (code "#t") ". Otherwise returns " (code "#f") " for a "
    87                                         "non-existent mailbox.") )
    88 
    89                                 (procedure "(drop-local-mailbox! NAME)"
    90                                         (p "Forget the local mailbox.") )
    91 
    92                                 (procedure "(make-remote-mailbox-tcp-server [PORT (default-remote-mailbox-port-number)])"
    93                                         (p "Uses make-tcp-server to create a server procedure on " (code "((remote-mailbox-listen-procedure) PORT)") ". "
    94                                         "The server threads spawned by this procedure are "
    95                                         "continuously processing remote mailbox sends until "
    96                                         "the connection is closed.")
    97 
    98                                         (p "A remote send will automatically create the requested local mailbox.")
    99 
    100                                         (p "Use " (code "(mailbox-receive! (get-local-mailbox NAME) ...)") " "
    101                                         "to get remote messages.") )
    102 
    103                                 (procedure "(run-remote-mailbox-server [PORT (default-remote-mailbox-port-number)])"
    104                                         (p "Returns the remote mailbox server thread. Should the server thread "
    105                                         "not exist it will be created with the specified " (code "((remote-mailbox-listen-procedure) PORT)") " "
    106                                         "and started.") )
    107 
    108                                 (procedure "(remote-mailbox-server-listener SERVER-THREAD)"
    109                                         (p "Returns the listener object for the specified " (tt "SERVER-THREAD") ", "
    110                                         "as created by " (code "run-remote-mailbox-server") ".") )
    111                         )
     10Purports to provide an API for sending and receiving remote messages. This egg
     11attempts to duplicate the '''mailbox''' egg semantics across an IP connection.
     12
     13=== Common Parameters
     14
     15==== default-remote-mailbox-tcp-port
     16
     17<procedure>(default-remote-mailbox-tcp-port [TCP-PORT])</procedure>
     18
     19The standard port number to establish a remote mailbox connection. Defaults to
     20{{63001}}.
     21
     22==== default-remote-mailbox-hostname
     23
     24<procedure>(default-remote-mailbox-hostname [HOST-NHAME])</procedure>
     25
     26The host name to establish a remote mailbox connection. Defaults to
     27{{"localhost"}}.
     28
     29
     30=== Client Parameters
     31
     32==== default-remote-mailbox-serializer
     33
     34<procedure>(default-remote-mailbox-serializer [PROCEDURE])</procedure>
     35
     36The optional serialize failure handler procedure. Must be {{#f}} or an
     37procedure/1.
     38
     39==== default-remote-mailbox-connect
     40
     41<procedure>(default-remote-mailbox-connect [PROCEDURE])</procedure>
     42
     43The procedure used to establish network connections for a remote mailbox.
     44Defaults to {{tcp-connect}} and must be signature-compatible.
     45
     46
     47=== Client Procedures
     48
     49==== remote-mailbox
     50
     51<procedure>(remote-mailbox NAME [#:hostname HOSTNAME] [#:tcp-port TCP-PORT] [#:connect CONNECT])</procedure>
     52
     53Returns a unique {{remote-mailbox}} object for the specified {{NAME}}.
     54
     55; HOSTNAME : A string. Defaults to {{(default-remote-mailbox-tcp-port)}}.
     56; TCP-PORT : A fixnum in [0 65535] or {{#f}}. Defaults to {{(default-remote-mailbox-hostname)}}.
     57; CONNECT : A procedure. Defaults to {{(default-remote-mailbox-connect)}}.
     58
     59When {{TCP-PORT}} is {{#f}} the {{HOSTNAME}} must contain the port or service.
     60
     61==== remote-mailbox?
     62
     63<procedure>(remote-mailbox? OBJECT)</procedure>
     64
     65Is the {{OBJECT}} a valid {{remote-mailbox}}?
     66
     67==== remote-mailbox-name
     68
     69<procedure>(remote-mailbox-name REMOTE-MAILBOX)</procedure>
     70
     71Returns the {{REMOTE-MAILBOX}} name.
     72
     73==== default-remote-mailbox-hostname
     74
     75<procedure>(default-remote-mailbox-hostname REMOTE-MAILBOX)</procedure>
     76
     77Returns the {{REMOTE-MAILBOX}} hostname.
     78
     79==== remote-mailbox-tcp-port
     80
     81<procedure>(remote-mailbox-tcp-port REMOTE-MAILBOX)</procedure>
     82
     83Returns the {{REMOTE-MAILBOX}} tcp-port.
     84
     85==== remote-mailbox-connected?
     86
     87<procedure>(remote-mailbox-connected? REMOTE-MAILBOX)</procedure>
     88
     89Is the {{REMOTE-MAILBOX}} connected? (Has it been used?)
     90
     91==== remote-mailbox-send!
     92
     93<procedure>(remote-mailbox-send! REMOTE-MAILBOX OBJECT [SERIALIZER])</procedure>
     94
     95Transmit the {{OBJECT}} to the {{REMOTE-MAILBOX}}, using the
     96{{SERIALIZER}}, which defaults to {{(default-remote-mailbox-serializer)}}.
     97
     98==== drop-remote-mailbox!
     99
     100<procedure>(drop-remote-mailbox! REMOTE-MAILBOX)</procedure>
     101
     102Invalidate and forget the {{REMOTE-MAILBOX}}.
     103
     104==== drop-all-remote-mailboxes
     105
     106<procedure>(drop-remote-mailboxes!)</procedure>
     107
     108Invalidate and forget all the remote mailboxes. Performs a reset to the initial state.
     109
     110
     111=== Server Parameters
     112
     113==== default-remote-mailbox-deserializer
     114
     115<procedure>(default-remote-mailbox-deserializer [PROCEDURE])</procedure>
     116
     117The optional deserialize failure handler procedure. Must be {{#f}} or a
     118procedure/2.
     119
     120==== default-remote-mailbox-listen
     121
     122<procedure>(default-remote-mailbox-listen [PROCEDURE])</procedure>
     123
     124The procedure used to establish network connections for a remote mailbox.
     125Defaults to {{tcp-listen}} and must be signature-compatible.
     126
     127==== default-remote-mailbox-auto-create?
     128
     129<procedure>(default-remote-mailbox-auto-create? [AUTO-CREATE?])</procedure>
     130
     131Automatically create local-mailbox? Defaults to {{#t}}.
     132
     133=== Server Procedures
     134
     135==== make-remote-mailbox-server
     136
     137<procedure>(make-remote-mailbox-server [#:name NAME] [#:tcp-port TCP-PORT] [#:listen LISTEN] [#:deserializer DESERIALIZER] [#:auto-create? AUTO-CREATE?] [#:debug DEBUG])</procedure>
     138
     139Creates and returns a {{remote-mailbox-server}}. Uses {{make-tcp-server}} to
     140create a server procedure. The server threads spawned by this procedure are
     141continuously processing remote mailbox sends until the connection is closed.)
     142
     143; NAME : Defaults to {{remote-mailbox-server:#}}
     144; TCP-PORT : Defaults to {{(default-remote-mailbox-tcp-port)}}
     145; LISTEN : Defaults to {{(default-remote-mailbox-listen)}}
     146; DESERIALIZER : Defaults to {{(default-remote-mailbox-deserializer)}}
     147; AUTO-CREATE? : Automatically create local-mailbox. Defaults to {{#t}}
     148; DEBUG : Print tcp diagnostics with {{DEBUG}} prefix when truw. Defaults to {{#f}}
     149
     150==== remote-mailbox-server?
     151
     152<procedure>(remote-mailbox-server? OBJECT)</procedure>
     153
     154Is the {{OBJECT}} a {{remote-mailbox-server}}?
     155
     156==== remote-mailbox-server-name
     157
     158<procedure>(remote-mailbox-server-name REMOTE-MAILBOX-SERVER)</procedure>
     159
     160Returns the name of the specified {{REMOTE-MAILBOX-SERVER}}.
     161
     162==== remote-mailbox-server-listener
     163
     164<procedure>(remote-mailbox-server-listener REMOTE-MAILBOX-SERVER)</procedure>
     165
     166Returns the listener object for the specified {{REMOTE-MAILBOX-SERVER}}.
     167
     168==== remote-mailbox-server-run!
     169
     170<procedure>(remote-mailbox-server-run! REMOTE-MAILBOX-SERVER)</procedure>
     171
     172Starts the server continuously processing remote mailbox sends until the
     173connection is closed.
     174
     175==== make-remote-mailbox-server-thread
     176
     177<procedure>(make-remote-mailbox-server-thread REMOTE-MAILBOX-SERVER)</procedure>
     178
     179Returns a thread that, when started, will run the {{REMOTE-MAILBOX-SERVER}}.
     180
     181==== local-mailbox/server
     182
     183<procedure>(local-mailbox/server REMOTE-MAILBOX-SERVER NAME)</procedure>
     184
     185Returns the mailbox of {{NAME}} for {{REMOTE-MAILBOX-SERVER}} (a mailbox object
     186as returned by the procedure {{make-mailbox}}). Returns {{#f}} should the
     187mailbox not exist.
     188
     189Should the mailbox not exist it will be created if the
     190{{REMOTE-MAILBOX-SERVER}} has a true {{AUTO-CREATE?}} flag.
     191
     192To receive remote messages:
     193<enscript language=scheme>
     194(mailbox-receive! (local-mailbox/server REMOTE-MAILBOX-SERVER NAME))
     195<enscript>
     196
     197==== drop-local-mailbox!/server
     198
     199<procedure>(drop-local-mailbox!/server REMOTE-MAILBOX-SERVER NAME)</procedure>
     200
     201Forget the server's mailbox.
     202
     203==== local-mailbox-names/server
     204
     205<procedure>(local-mailbox-names/server REMOTE-MAILBOX-SERVER)</procedure>
     206
     207Returns a list of all the mailboxes created for the server.
     208
     209==== local-mailbox
     210
     211<procedure>(local-mailbox NAME [DEBUG])</procedure>
     212
     213This is a convenience interface and only recommended for the simplest of
     214situations.
     215
     216When {{NAME}} is:
     217
     218; default-remote-mailbox-server-thread : returns the thread for the default server.
     219; default-remote-mailbox-server : returns the default server record.
     220; <other symbol> : returns the mailbox for {{NAME}}.
     221
     222The {{DEBUG}} argument is passed on to {{tcp-server}} which will print tcp
     223diagnostics with {{DEBUG}} as a prefix. The other parameters to
     224{{make-remote-mailbox-server}} are defaulted.
     225
     226The default server is created and run a separate thread upon the first call.
     227
     228To receive remote messages:
     229<enscript language=scheme>
     230(mailbox-receive! (local-mailbox NAME))
     231</enscript>
     232
    112233
    113234== Usage
     
    123244== Notes
    124245
    125 * (p "The sender (client) identity is not part of this API.")
     246* The sender (client) identity is not part of this API.
     247
     248* "Curry" to supply {{BACKLOG}} and/or {{HOST}} arguments to the {{listen}}
     249procedure.
    126250
    127251
    128252== Requirements
    129253
     254[[tcp-server]]
     255[[s11n]]
     256[[mailbox]]
     257[[miscmacros]]
     258[[synch]]
     259[[lookup-table]]
     260[[type-errors]]
     261
    130262
    131263== Bugs and Limitations
     
    139271== Version history
    140272
    141 ; 1.0.0 :
     273; 2.0.0 : Initial Chicken 4 release.
    142274
    143275
  • release/4/remote-mailbox/trunk/remote-mailbox.meta

    r15942 r15957  
    77 (doc-from-wiki)
    88 (synopsis "Remote Mailbox")
    9  (needs setup-helper tcp-server s11n mailbox miscmacros synch misc-extn lookup-table)
     9 (needs setup-helper tcp-server s11n mailbox miscmacros lookup-table check-errors)
    1010 (files
    1111  "tests"
  • release/4/remote-mailbox/trunk/remote-mailbox.scm

    r15945 r15957  
    99  ;; Common
    1010  ; Parameters
    11   default-remote-mailbox-port-number
    12   default-remote-mailbox-host-name
     11  default-remote-mailbox-tcp-port
     12  default-remote-mailbox-hostname
    1313  ;; Client
    1414  ; Parameters
    15   default-remote-mailbox-connect-procedure
     15  default-remote-mailbox-connect
    1616  default-remote-mailbox-serializer
    17   default-remote-mailbox-deserializer
    18   default-remote-mailbox-listen-procedure
     17  default-remote-mailbox-listen
    1918  ; Operations
    2019  remote-mailbox
    2120  remote-mailbox?
    2221  remote-mailbox-name
    23   remote-mailbox-host-name
    24   remote-mailbox-port-number
     22  remote-mailbox-hostname
     23  remote-mailbox-tcp-port
    2524  remote-mailbox-connected?
    2625  drop-remote-mailbox!
    27   drop-all-remote-mailboxs!
     26  drop-remote-mailboxes!
     27  remote-mailboxes
    2828  remote-mailbox-send!
    2929  ;; Server
    3030  ; Parameters
    3131  default-remote-mailbox-deserializer
    32   default-remote-mailbox-listen-procedure
    33   default-remote-mailbox-auto-create
     32  default-remote-mailbox-listen
     33  default-remote-mailbox-auto-create?
    3434  ; Operations
    35   local-mailbox
    36   drop-local-mailbox!
    3735  make-remote-mailbox-server
    3836  remote-mailbox-server?
    3937  remote-mailbox-server-name
    4038  remote-mailbox-server-listener
    41   remote-mailbox-server-start
    42   run-remote-mailbox-server)
     39  remote-mailbox-server-thread
     40  remote-mailbox-server-mailbox
     41  drop-remote-mailbox-server-mailbox!
     42  remote-mailbox-server-mailbox-names
     43  remote-mailbox-server-start!
     44  ;; Convenience
     45  lcoal-mailbox)
    4346
    4447  (import scheme
     
    5558          type-checks
    5659          conditions)
    57          
     60
    5861  (require-library srfi-18 tcp
    5962                   tcp-server s11n mailbox miscmacros synch lookup-table type-checks conditions)
    6063
    61   (declare
    62      (bound-to-procedure
    63       remote-mailbox-name) )
    64 
    6564;;;
    6665
     
    7170(define-constant INITIAL-DICT-SIZE 4)
    7271
    73 (define (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
     72(define (make-dict-identity/synch id #!optional (guess INITIAL-DICT-SIZE))
    7473  (make-object/synch (make-dict guess eq?) id) )
    7574
     
    7877(define mailbox-name? symbol?)
    7978
    80 (define (port-number? obj)
     79(define (tcp-port? obj)
    8180        (and (fixnum? obj)
    8281             (and (fx< 0 obj) (fx< obj 65536)) ) )
    8382
    84 (define (host-name? obj)
     83(define (hostname? obj)
    8584  (and (string? obj) (not (string-null? obj))) )
    8685
    8786;;; Conditions
    8887
    89 (define (make-remote-mailbox-exception loc msg . args)
     88(define (make-remote-mailbox-condition loc msg . args)
    9089        (make-exn-condition+ loc msg args 'remote-mailbox) )
     90
     91(define (remote-mailbox-exception loc msg . args)
     92  (abort (apply make-remote-mailbox-condition loc msg args)) )
    9193
    9294;;; Remote Mailbox Packet
     
    110112;;; Communication IP Port
    111113
    112 (define-parameter default-remote-mailbox-port-number 63001
     114(define-parameter default-remote-mailbox-tcp-port 63001
    113115        (lambda (x)
    114                 (cond ((port-number? x) x)
    115           (else (default-remote-mailbox-port-number) ) ) ) )
    116 
    117 (define-parameter default-remote-mailbox-host-name "localhost"
     116                (cond ((tcp-port? x) x)
     117          (else (default-remote-mailbox-tcp-port) ) ) ) )
     118
     119(define-parameter default-remote-mailbox-hostname "localhost"
    118120        (lambda (x)
    119                 (cond ((host-name? x) x)
    120           (else (default-remote-mailbox-host-name) ) ) ) )
     121                (cond ((hostname? x) x)
     122          (else (default-remote-mailbox-hostname) ) ) ) )
     123
    121124
    122125;;; Client Side
    123126
    124127;; Support
    125 
    126 (define (make-remote-mailbox-mutex)
    127         (make-dict-unique/synch 'fullname->remote-mailbox) )
    128 
    129 (define fullname->remote-mailbox (make-remote-mailbox-mutex))
    130 
    131 (define (make-remote-mailbox-key name host-name port-number)
    132         (conc name #\@ host-name #\: port-number) )
    133128
    134129(define-record-type remote-mailbox
     
    136131        *remote-mailbox?
    137132        (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)
     133        (hstnam remote-mailbox-hostname)
     134        (prtnum remote-mailbox-tcp-port)
     135        (connect remote-mailbox-connect)
    141136        (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!) )
    144 
    145 (define (invalidate-remote-mailbox! rmb)
    146         (remote-mailbox-name-set! rmb #f) )
    147 
    148 (define (valid-remote-mailbox? rmb)
    149         (->boolean (remote-mailbox-name rmb)) )
     137        (input remote-mailbox-input-port remote-mailbox-input-port-set!)
     138        (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
     139
     140(define (invalidate-remote-mailbox! rmb) (remote-mailbox-name-set! rmb #f))
     141(define (valid-remote-mailbox? rmb) (->boolean (remote-mailbox-name rmb)))
     142
     143(define (remote-mailbox-key rmb) (mutex-name (remote-mailbox-mutex rmb)))
     144
     145(define (make-remote-mailbox-mutex)
     146        (make-dict-identity/synch 'fullname->remote-mailbox) )
     147
     148(define +fullname->remote-mailbox+ (make-remote-mailbox-mutex))
     149
     150(define (make-remote-mailbox-key name hostname tcp-port)
     151        (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
    150152
    151153;;
    152154
    153155(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 hostname)
     157(define-check+error-type tcp-port)
    156158(define-check+error-type remote-mailbox)
    157159
    158160;;
    159161
     162(define (*remote-mailbox-connected? rmb) (->boolean (remote-mailbox-output-port rmb)))
     163
    160164(define (get-connection rmb)
    161         (let ((out (remote-mailbox-output-port-number rmb)))
    162     ; existing connection?
    163                 (if out (values (remote-mailbox-input-port-number rmb) out)
    164         ; else make a connection
    165         (let-values (((in out)
    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)
    171           (values in out) )) ) )
     165        (if (*remote-mailbox-connected? rmb)
     166      (values (remote-mailbox-input-tcp-port rmb) (remote-mailbox-output-tcp-port rmb))
     167      ; else make a connection
     168      (let-values (((in out)
     169                    (let ((connect (remote-mailbox-connect rmb))
     170                          (tcp-port (remote-mailbox-tcp-port rmb)) )
     171                      (if tcp-port
     172                          (connect (remote-mailbox-hostname rmb) tcp-port)
     173                          (connect (remote-mailbox-hostname rmb)) ) ) ) )
     174        (remote-mailbox-output-port-set! rmb out)
     175        (remote-mailbox-input-port-set! rmb in)
     176        (values in out) )) )
    172177
    173178(define (close-remote-mailbox-connection! rmb)
    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)
     179        (close-input-port (remote-mailbox-input-port rmb))
     180        (close-output-port (remote-mailbox-output-port rmb))
     181        (remote-mailbox-output-port-set! rmb #f)
     182        (remote-mailbox-input-port-set! rmb #f)
    178183        (invalidate-remote-mailbox! rmb) )
    179184
    180185(define (close-all-remote-mailbox-connections!)
    181         (%let/synch ((n->o fullname->remote-mailbox))
    182         (dict-for-each n->o
    183          (lambda (key rmb)
    184                    (synch (remote-mailbox-mutex rmb)
    185              (close-remote-mailbox-connection! rmb) ) ) ) ) )
     186        (%let/synch ((n->o +fullname->remote-mailbox+))
     187        (dict-for-each
     188          n->o
     189          (lambda (key rmb)
     190            (record/synch remote-mailbox rmb (close-remote-mailbox-connection! rmb))) ) ) )
    186191
    187192;;; Exported
     
    195200          (else (default-remote-mailbox-serializer))) ) )
    196201
    197 (define-parameter default-remote-mailbox-connect-procedure tcp-connect
     202(define-parameter default-remote-mailbox-connect tcp-connect
    198203  (lambda (x)
    199204        (cond ((procedure? x) x)
    200           (else (default-remote-mailbox-connect-procedure) ) ) ) )
     205          (else (default-remote-mailbox-connect) ) ) ) )
    201206
    202207;; Operations
    203208
    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)))
     209(define (remote-mailbox name #!key (hostname (default-remote-mailbox-hostname))
     210                                   (tcp-port (default-remote-mailbox-tcp-port))
     211                                   (connect (default-remote-mailbox-connect)))
    207212        (check-mailbox-name 'remote-mailbox name)
    208         (check-host-name 'remote-mailbox host-name)
    209         (check-port-number 'remote-mailbox port-number)
     213        (check-hostname 'remote-mailbox hostname)
     214        (when tcp-port (check-tcp-port 'remote-mailbox tcp-port))
    210215        (check-procedure 'remote-mailbox connect)
    211         (let ((key (make-remote-mailbox-key name host-name port-number)))
    212                 (%let/synch ((n->o fullname->remote-mailbox))
     216        (let ((key (make-remote-mailbox-key name hostname tcp-port)))
     217                (%let/synch ((n->o +fullname->remote-mailbox+))
    213218                        (or (dict-ref n->o key)
    214                                         (let ((rmb (*make-remote-mailbox name host-name port-number
    215                                                                          connect
    216                                                                          (make-mutex key) #f #f)))
     219                                        (let ((rmb (*make-remote-mailbox name hostname tcp-port connect (make-mutex key) #f #f)))
    217220                                                (dict-set! n->o key rmb)
    218221                                                rmb ) ) ) ) )
     
    223226(define (remote-mailbox-connected? rmb)
    224227        (check-remote-mailbox 'remote-mailbox-connected? rmb)
    225         (->boolean (remote-mailbox-output-port-number rmb)) )
     228        (*remote-mailbox-connected? rmb) )
     229
     230(define (remote-mailboxes)
     231        (close-all-remote-mailbox-connections!)
     232        (%let/synch ((n->o +fullname->remote-mailbox+))
     233          (dict-values n->o) ) )
    226234
    227235(define (drop-remote-mailbox! rmb)
    228236        (check-remote-mailbox 'drop-remote-mailbox! rmb)
    229         (let ((mutex (remote-mailbox-mutex rmb)))
    230                 (synch mutex
    231                         (close-remote-mailbox-connection! rmb)
    232                         (%let/synch ((n->o fullname->remote-mailbox))
    233                                 (dict-delete! n->o (mutex-specific mutex)) ) ) ) )
    234 
    235 (define (drop-all-remote-mailboxs!)
     237        (record/synch remote-mailbox rmb
     238    (close-remote-mailbox-connection! rmb)
     239    (%let/synch ((n->o +fullname->remote-mailbox+))
     240      (dict-delete! n->o (remote-mailbox-key rmb)) ) ) )
     241
     242(define (drop-remote-mailboxes!)
    236243        (close-all-remote-mailbox-connections!)
    237         (set! fullname->remote-mailbox (make-remote-mailbox-mutex)) )
     244        (set! +fullname->remote-mailbox+ (make-remote-mailbox-mutex)) )
    238245
    239246(define (remote-mailbox-send! rmb obj #!optional (serializer (default-remote-mailbox-serializer)))
    240247        (check-remote-mailbox 'remote-mailbox-send! rmb)
    241         (synch (remote-mailbox-mutex rmb)
     248        (record/synch remote-mailbox rmb
    242249                (let-values (((in out) (get-connection rmb)))
    243250                        (serialize (make-remote-mailbox-packet rmb obj) out serializer) ) ) )
     251
    244252
    245253;;; Server Side
     
    254262            (default-remote-mailbox-deserializer) ) ) ) )
    255263
    256 (define-parameter default-remote-mailbox-listen-procedure tcp-listen
     264(define-parameter default-remote-mailbox-listen tcp-listen
    257265  (lambda (x)
    258266        (cond ((procedure? x) x)
    259267          (else
    260             (default-remote-mailbox-listen-procedure) ) ) ) )
    261 
    262 (define-parameter default-remote-mailbox-auto-create #t
     268            (default-remote-mailbox-listen) ) ) ) )
     269
     270(define-parameter default-remote-mailbox-auto-create? #t
    263271  (lambda (x)
    264272    x ) )
     
    266274;; Support
    267275
    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)
    273               (mailbox-send!
    274                (local-mailbox (remote-mailbox-packet-mailbox-name req) auto-create?)
    275                (remote-mailbox-packet-mailbox-value req)))
    276             (else
    277               (signal
    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)) )
    285 
    286 (define name->mailbox (make-dict-unique/synch 'name->mailbox))
    287 
    288276(define-check+error-type remote-mailbox-server)
    289277
     278(define ((make-remote-mailbox-server-thunk rmbs))
     279  (let ((req (deserialize (current-input-port) (remote-mailbox-server-auto-deserializer rmbs))))
     280    (cond ((eq? (void) req)
     281            ;ignore void transmissions
     282            )
     283          ((remote-mailbox-packet? req)
     284            (let* ((nam (remote-mailbox-packet-mailbox-name req))
     285                   (lmb (local-mailbox nam (remote-mailbox-server-auto-create? rmbs))) )
     286              (if (not lmb)
     287                  (remote-mailbox-exception 'remote-mailbox-server
     288                    "unknown local mailbox" nam)
     289                  (mailbox-send! lmb (remote-mailbox-packet-mailbox-value req)) ) ) )
     290          (else
     291            (remote-mailbox-exception 'remote-mailbox-server
     292              "unknown remote mailbox client request" req) ) ) ) )
     293
     294(define (make-remote-mailbox-tcp-server rmbs)
     295        (make-tcp-server (remote-mailbox-server-listener rmbs)
     296                         (make-remote-mailbox-server-thunk rmbs)) )
     297
     298(define (dict-mailbox dict-mutex name auto-create?)
     299  (%let/synch ((n->o dict-mutex))
     300                (or (dict-ref n->o name)
     301                                (and auto-create?
     302             (let ((mb (make-mailbox name)))
     303               (dict-set! n->o name mb)
     304               mb ) ) ) ) )
     305
     306(define (drop-dict-mailbox! dict-mutex name)
     307        (%let/synch ((n->o  dict-mutex)) (dict-delete! n->o name) ) )
     308
     309(define (dict-mailbox-names dict-mutex)
     310        (%let/synch ((n->o  dict-mutex)) (dict-keys n->o) ) )
     311
    290312;; Exported
    291313
    292 (define (local-mailbox name #!optional (create? #f))
    293         (check-mailbox-name 'local-mailbox name)
    294         (%let/synch ((n->o name->mailbox))
    295                 (or (dict-ref n->o name)
    296                                 (and create?
    297              (let ((ch (make-mailbox name)))
    298                (dict-set! n->o name ch)
    299                ch ) ) ) ) )
    300 
    301 (define (drop-local-mailbox! name)
    302         (%let/synch ((n->o name->mailbox))
    303                 (dict-delete! n->o name) ) )
    304 
    305 (define (local-mailbox-names)
    306         (%let/synch ((n->o name->mailbox))
    307     (dict-keys n->o) ) )
    308 
    309314(define-record-type remote-mailbox-server
    310   (*make-remote-mailbox-server thread listener)
     315  (*make-remote-mailbox-server dctm autof desrl thread listener)
    311316  remote-mailbox-server?
    312   (thread remote-mailbox-server-thread)
     317  (dctm remote-mailbox-server-dict-mutex)
     318  (autof remote-mailbox-server-auto-create?)
     319  (desrl remote-mailbox-server-auto-deserializer)
     320  (thread remote-mailbox-server-thread remote-mailbox-server-thread-set!)
    313321  (listener remote-mailbox-server-listener) )
    314322
    315 (define (remote-mailbox-server-name server)
    316   (thread-name (remote-mailbox-server-thread server)) )
    317 
    318323(define (make-remote-mailbox-server
    319           #!key (port-number (default-remote-mailbox-port-number))
    320                 (listen (default-remote-mailbox-listen-procedure))
     324          #!key (tcp-port (default-remote-mailbox-tcp-port))
     325                (listen (default-remote-mailbox-listen))
    321326                (deserializer (default-remote-mailbox-deserializer))
    322327                (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)) )
    333 
    334 (define run-remote-mailbox-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 ) ) ) ) )
     328                (auto-create? (default-remote-mailbox-auto-create?))
     329                (server-mailbox? #f)
     330                debug)
     331        (check-tcp-port 'make-remote-mailbox-server tcp-port)
     332        (check-procedure 'make-remote-mailbox-server listen)
     333        (check-procedure 'make-remote-mailbox-server deserializer)
     334  (let* ((listener (listen tcp-port))
     335         (rmbs (*make-remote-mailbox-server (make-dict-identity/synch name)
     336                                            auto-create? deserializer #f istener)) )
     337    (let* ((tcp-server (make-remote-mailbox-tcp-server rmbs))
     338           (thunk (if debug (lambda () (tcp-server debug)) tcp-server)) )
     339      (remote-mailbox-server-thread-set! rmbs (make-thread thunk name))
     340      rmbs ) ) )
     341
     342(define (remote-mailbox-server-name rmbs)
     343        (check-remote-mailbox-server 'remote-mailbox-server-name rmbs)
     344  (thread-name (remote-mailbox-server-thread rmbs)) )
     345
     346(define (remote-mailbox-server-mailbox rmbs name)
     347        (check-remote-mailbox-server 'remote-mailbox-server-mailbox rmbs)
     348        #;(check-mailbox-name 'remote-mailbox-server-mailbox name)
     349        (dict-mailbox (remote-mailbox-server-dict-mutex rmbs)
     350                      name
     351                      (remote-mailbox-server-auto-create? rmbs)) )
     352
     353(define (drop-remote-mailbox-server-mailbox! rmbs name)
     354        (check-remote-mailbox-server 'drop-remote-mailbox-server-mailbox! rmbs)
     355        #;(check-mailbox-name 'drop-remote-mailbox-server-mailbox! name)
     356        (drop-dict-mailbox! (remote-mailbox-server-dict-mutex rmbs) name) )
     357
     358(define (remote-mailbox-server-mailbox-names rmbs)
     359        (check-remote-mailbox-server 'server-mailbox-names rmbs)
     360        (dict-mailbox-names (remote-mailbox-server-dict-mutex rmbs)) )
     361
     362(define (remote-mailbox-server-start! rmbs)
     363        (check-remote-mailbox-server 'remote-mailbox-server-start! rmbs)
     364  (thread-start! (remote-mailbox-server-thread rmbs)) )
     365
     366;;; Convenience
     367
     368(define lcoal-mailbox
     369  (let ((the-rmbs #f))
     370    (lambda (#!optional name debug)
     371      (let ((rmbs (or the-rmbs
     372                      (begin
     373                        (set! the-rmbs (make-remote-mailbox-server #:debug debug))
     374                        (remote-mailbox-server-start! the-rmbs)
     375                        the-rmbs))))
     376        (cond (name (remote-mailbox-server-mailbox rmbs name))
     377              (else rmbs) ) ) ) ) )
    352378
    353379) ;module remote-mailbox
  • release/4/remote-mailbox/trunk/remote-mailbox.setup

    r15942 r15957  
    55(verify-extension-name "remote-mailbox")
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "0.0.0")
     7(required-extension-version
     8  "synch"                   "2.0.1"
     9  "lookup-table"            "1.11.0")
     10
     11(setup-shared-extension-module 'remote-mailbox-common (extension-version "2.0.0")
    812  #:compile-options '(-fixnum-arithmetic
    913                      -optimize-level 3
    1014                      -no-procedure-checks))
     15
     16(setup-shared-extension-module 'remote-mailbox-client (extension-version "2.0.0")
     17  #:compile-options '(-fixnum-arithmetic
     18                      -optimize-level 3
     19                      -no-procedure-checks))
     20
     21(setup-shared-extension-module 'remote-mailbox-server (extension-version "2.0.0")
     22  #:compile-options '(-fixnum-arithmetic
     23                      -optimize-level 3
     24                      -no-procedure-checks))
     25
     26(install-extension-tag (extension-name) (extension-version "2.0.0"))
  • release/4/remote-mailbox/trunk/tests/remote-mailbox-test.scm

    r15942 r15957  
    44
    55(use srfi-1 posix srfi-18)
    6 (use remote-mailbox mailbox miscmacros)
     6(use remote-mailbox-client remote-mailbox-server mailbox miscmacros)
    77
    88(define-constant NUM-MSG 5)
     
    1111(define (client)
    1212  (print "* Client - Sending " NUM-MSG " messages")
    13         (let ((rmb (get-remote-mailbox 'foo)))
     13        (let ((rmb (remote-mailbox 'foo)))
    1414                (dotimes (n NUM-MSG)
    1515                        (printf "Sending message number ~A to ~A~%" n RCV-NAM)
     
    2222(define (server)
    2323  (print "* Server - Receiving messages until 'quit")
    24         (run-remote-mailbox-server)
    2524        (thread-start!
    2625                (lambda ()
    27                         (let loop ((msg (mailbox-receive! (get-local-mailbox 'foo))))
     26                        (let loop ((msg (mailbox-receive! (local-mailbox 'foo "test: "))))
    2827                                (print "Received " msg)
    29                                 (if (eq? 'quit msg)
    30             (exit 0)
    31             (loop (mailbox-receive! (get-local-mailbox 'foo))) ) ) ))
    32         (thread-join! (run-remote-mailbox-server)) )
     28                                (if (eq? 'quit msg) (exit 0)
     29            (loop (mailbox-receive! (local-mailbox 'foo "test: "))) ) ) ))
     30        (thread-join! (local-mailbox 'default-remote-mailbox-server-thread)) )
    3331
    3432(define operation
     
    3937(if operation
    4038    (case operation
    41       ((client)
    42         (client))
    43       ((server)
    44         (server))
     39      ((client) (client))
     40      ((server) (server))
    4541      (else
    4642        (error 'remote-mailbox-test "Unrecognized operation: " operation) ) )
     
    4844      #;(print "Running Server: " cmd)
    4945      (process-run cmd `("server"))
    50       #;(sleep 1) ; This might be needed
     46      (sleep 1) ; This might be needed
    5147      #;(print "Running Client: " cmd)
    5248      (process-execute cmd `("client")) ) )
Note: See TracChangeset for help on using the changeset viewer.