Changeset 11636 in project


Ignore:
Timestamp:
08/14/08 05:22:23 (12 years ago)
Author:
Kon Lovett
Message:

Cosmetic changes.

Location:
release/3/remote-mailbox/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/remote-mailbox/trunk/remote-mailbox.html

    r8938 r11636  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>0.4 Added lookup-table rqrmnt</li>
    161 <li>0.3 Incompatible API changes, see get-local-mailbox, make-remote-mailbox-server, run-remote-mailbox-server</li>
    162 <li>0.2 Needs misc-extn &gt; 2.0</li>
    163 <li>0.1 Initial release</li></ul></div>
    164 <div class="section">
    165158<h3>Requires</h3>
    166159<ul>
     
    252245<p>The sender (client) identity is not part of this API.</p>
    253246<p>The use of port 3001 (in the reserved range) is problematic.</p></div>
     247<div class="section">
     248<h3>Version</h3>
     249<ul>
     250<li>1.0 </li>
     251<li>0.4 Added lookup-table rqrmnt</li>
     252<li>0.3 Incompatible API changes, see get-local-mailbox, make-remote-mailbox-server, run-remote-mailbox-server</li>
     253<li>0.2 Needs misc-extn &gt; 2.0</li>
     254<li>0.1 Initial release</li></ul></div>
    254255<div class="section">
    255256<h3>License</h3>
  • release/3/remote-mailbox/trunk/remote-mailbox.scm

    r8938 r11636  
    3939    (no-bound-checks)
    4040    (inline)
    41     (fixnum) ) )
     41    (fixnum)
     42    (bound-to-procedure
     43      %remote-mailbox-name) ) )
    4244
    4345;;;
    4446
    4547(define (->boolean x)
    46   (not (not x)) )
     48  (and x
     49       #t) )
     50
     51;;;
     52
     53(define-inline (tcp-portno? obj)
     54        (and (fixnum? obj)
     55             (and (fx< 0 obj) (fx< obj 65536)) ) )
    4756
    4857;;; Synchronized Dictionary
     
    5059(define-constant INITIAL-DICT-SIZE 4)
    5160
    52 (define (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
     61(define-inline (make-dict-unique/synch id #!optional (guess INITIAL-DICT-SIZE))
    5362  (make-object/synch (make-dict guess eq?) id) )
    5463
    55 ;;;
    56 
    57 (define remote-mailbox-tag 'RCH)
    58 
    59 (define (make-remote-mailbox-packet rch obj)
    60         (vector remote-mailbox-tag (%remote-mailbox-name rch) obj) )
    61 
    62 (define (remote-mailbox-packet-mailbox-name obj)
    63         (vector-ref obj 1) )
    64 
    65 (define (remote-mailbox-packet-mailbox-value obj)
    66         (vector-ref obj 2) )
    67 
    68 (define (remote-mailbox-packet? obj)
     64;;; Local Exceptional Conditions
     65
     66(define (make-exn-condition loc msg . args)
     67  (if (null? args)
     68      (make-property-condition 'exn 'location loc 'message msg)
     69      (make-property-condition 'exn 'location loc 'message msg 'arguments args) ) )
     70
     71(define (make-remote-mailbox-exception loc msg . args)
     72        (make-composite-condition
     73   (apply make-exn-condition loc msg args)
     74         (make-property-condition 'remote-mailbox)) )
     75
     76;;; Remote Mailbox Packet
     77
     78(define remote-mailbox-tag 'rmb)
     79
     80(define-inline (make-remote-mailbox-packet rmb val)
     81        (vector remote-mailbox-tag (%remote-mailbox-name rmb) val) )
     82
     83(define-inline (remote-mailbox-packet-mailbox-tag rmp)
     84        (vector-ref rmp 0) )
     85
     86(define-inline (remote-mailbox-packet-mailbox-name rmp)
     87        (vector-ref rmp 1) )
     88
     89(define-inline (remote-mailbox-packet-mailbox-value rmp)
     90        (vector-ref rmp 2) )
     91
     92(define-inline (remote-mailbox-packet? obj)
    6993        (and (vector? obj)
    7094                         (= 3 (vector-length obj))
    71                          (eq? remote-mailbox-tag (vector-ref obj 0))) )
    72 
    73 (define (make-remote-mailbox-exception loc msg . args)
    74         (make-composite-condition
    75                 (make-property-condition 'exn 'message msg 'location loc 'arguments args)
    76                 (make-property-condition 'rch)) )
    77 
    78 ;;;
    79 
    80 (define (tcp-portno? obj)
    81         (and (fixnum? obj)
    82              (< 0 obj 65536)) )
    83 
    84 ;;;
     95                         (eq? remote-mailbox-tag (remote-mailbox-packet-mailbox-tag obj))) )
     96
     97;;; Communication IP Port
    8598
    8699(define-constant INITIAL-REMOTE-MAILBOX-PORT 3001)
     
    90103        (lambda (x)
    91104                (if (tcp-portno? x)
    92                         x
    93                         (default-remote-mailbox-port)) ) )
     105        x
     106        (default-remote-mailbox-port)) ) )
    94107
    95108;;; Client Side
     109
     110;; Support
    96111
    97112(define (make-remote-mailbox-mutex)
     
    114129        (output %remote-mailbox-output-port %remote-mailbox-output-port-set!) )
    115130
    116 (define (invalidate-remote-mailbox! rch)
    117         (%remote-mailbox-name-set! rch #f) )
    118 
    119 (define (valid-remote-mailbox? rch)
    120         (->boolean (%remote-mailbox-name rch)) )
    121 
    122 (define (check-mailbox-name obj loc)
     131(define (invalidate-remote-mailbox! rmb)
     132        (%remote-mailbox-name-set! rmb #f) )
     133
     134(define (valid-remote-mailbox? rmb)
     135        (->boolean (%remote-mailbox-name rmb)) )
     136
     137(define (check-mailbox-name loc obj)
    123138        (unless (symbol? obj)
    124139                (error loc "mailbox name not a symbol" obj)) )
    125140
    126 (define (check-host obj loc)
     141(define (check-host loc obj)
    127142        (unless (string? obj)
    128143                (error loc "host not a string" obj)) )
    129144
    130 (define (check-port obj loc)
     145(define (check-port loc obj)
    131146        (unless (tcp-portno? obj)
    132147                (error loc "invalid port" obj)) )
    133148
    134 (define (check-remote-mailbox rch loc)
    135         (unless (%remote-mailbox? rch)
    136                 (error loc "not a remote mailbox" rch)) )
    137 
    138 (define (check-valid-remote-mailbox rch loc)
    139         (check-remote-mailbox rch loc)
    140         (unless (valid-remote-mailbox? rch)
    141                 (error loc "not a valid remote mailbox" rch)) )
    142 
    143 (define (get-connection rch)
    144         (let ([out (%remote-mailbox-output-port rch)])
     149(define (check-remote-mailbox loc rmb)
     150        (unless (%remote-mailbox? rmb)
     151                (error loc "not a remote mailbox" rmb)) )
     152
     153(define (check-valid-remote-mailbox loc rmb)
     154        (check-remote-mailbox loc rmb)
     155        (unless (valid-remote-mailbox? rmb)
     156                (error loc "not a valid remote mailbox" rmb)) )
     157
     158(define (get-connection rmb)
     159        (let ([out (%remote-mailbox-output-port rmb)])
    145160                (if out
    146                   ; then we have a connection
    147                         (values (%remote-mailbox-input-port rch) out)
    148                         ; else make a connection
    149                         (let-values ([(in out)
    150                                                                                 ((%remote-mailbox-connect-procedure rch)
    151                                                                                         (%remote-mailbox-host rch)
    152                                                                                         (%remote-mailbox-port rch))])
    153                                 (%remote-mailbox-output-port-set! rch out)
    154                                 (%remote-mailbox-input-port-set! rch in)
    155                                 (values in out) )) ) )
    156 
    157 (define (close-remote-mailbox-connection! rch)
    158         (close-input-port (%remote-mailbox-input-port rch))
    159         (close-output-port (%remote-mailbox-output-port rch))
    160         (%remote-mailbox-output-port-set! rch #f)
    161         (%remote-mailbox-input-port-set! rch #f)
    162         (invalidate-remote-mailbox! rch) )
     161        ; then we have a connection
     162        (values (%remote-mailbox-input-port rmb) out)
     163        ; else make a connection
     164        (let-values ([(in out)
     165                      ((%remote-mailbox-connect-procedure rmb)
     166                       (%remote-mailbox-host rmb)
     167                       (%remote-mailbox-port rmb))])
     168          (%remote-mailbox-output-port-set! rmb out)
     169          (%remote-mailbox-input-port-set! rmb in)
     170          (values in out) )) ) )
     171
     172(define (close-remote-mailbox-connection! rmb)
     173        (close-input-port (%remote-mailbox-input-port rmb))
     174        (close-output-port (%remote-mailbox-output-port rmb))
     175        (%remote-mailbox-output-port-set! rmb #f)
     176        (%remote-mailbox-input-port-set! rmb #f)
     177        (invalidate-remote-mailbox! rmb) )
    163178
    164179(define (close-all-remote-mailbox-connections!)
    165180        (%let/synch ([n->o fullname->remote-mailbox])
    166181        (dict-for-each n->o
    167                 (lambda (key rch)
    168                                 (synch (%remote-mailbox-mutex rch)
    169                                 (close-remote-mailbox-connection! rch) ) ) ) ) )
    170 
    171 ;;;
     182         (lambda (key rmb)
     183                   (synch (%remote-mailbox-mutex rmb)
     184             (close-remote-mailbox-connection! rmb) ) ) ) ) )
     185
     186;;; Exported
     187
     188;; Parameters
    172189
    173190(define-parameter remote-mailbox-serializer
    174191  #f
    175192  (lambda (x)
    176         (cond
    177                 [(procedure? x) x]
    178                 [(not x) #f]
    179                 [else (remote-mailbox-serializer)]) ) )
     193        (cond [(procedure? x) x]
     194          [(not x) #f]
     195          [else (remote-mailbox-serializer)]) ) )
    180196
    181197(define-parameter remote-mailbox-connect-procedure
     
    183199  (lambda (x)
    184200        (if (procedure? x)
    185                 x
    186                 (remote-mailbox-connect-procedure)) ) )
     201        x
     202        (remote-mailbox-connect-procedure)) ) )
     203
     204;; Operations
    187205
    188206(define (get-remote-mailbox name #!optional (host "localhost") (port (default-remote-mailbox-port)))
    189         (check-mailbox-name name 'get-remote-mailbox)
    190         (check-host host 'get-remote-mailbox)
    191         (check-port port 'get-remote-mailbox)
     207        (check-mailbox-name 'get-remote-mailbox name)
     208        (check-host 'get-remote-mailbox host)
     209        (check-port 'get-remote-mailbox port)
    192210        (let ([key (make-remote-mailbox-key name host port)])
    193211                (%let/synch ([n->o fullname->remote-mailbox])
    194212                        (or (dict-ref n->o key)
    195                                         (let ([rch
    196                   (%make-remote-mailbox name host port
    197                     (remote-mailbox-connect-procedure)
    198                     (make-mutex key) #f #f)])
    199                                                 (dict-set! n->o key rch)
    200                                                 rch )) ) ) )
     213                                        (let ([rmb (%make-remote-mailbox name host port
     214                                                                         (remote-mailbox-connect-procedure)
     215                                                                         (make-mutex key) #f #f)])
     216                                                (dict-set! n->o key rmb)
     217                                                rmb ) ) ) ) )
    201218
    202219(define (remote-mailbox? obj)
    203220        (and (%remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    204221
    205 (define (remote-mailbox-name rch)
    206         (check-remote-mailbox rch 'remote-mailbox-name)
    207         (%remote-mailbox-name rch) )
    208 
    209 (define (remote-mailbox-host rch)
    210         (check-remote-mailbox rch 'remote-mailbox-host)
    211         (%remote-mailbox-host rch) )
    212 
    213 (define (remote-mailbox-port rch)
    214         (check-remote-mailbox rch 'remote-mailbox-port)
    215         (%remote-mailbox-port rch) )
    216 
    217 (define (remote-mailbox-connected? rch)
    218         (check-remote-mailbox rch 'remote-mailbox-connected?)
    219         (->boolean (%remote-mailbox-output-port rch)) )
    220 
    221 (define (drop-remote-mailbox! rch)
    222         (check-valid-remote-mailbox rch 'drop-remote-mailbox!)
    223         (let ([mutex (%remote-mailbox-mutex rch)])
     222(define (remote-mailbox-name rmb)
     223        (check-remote-mailbox 'remote-mailbox-name rmb)
     224        (%remote-mailbox-name rmb) )
     225
     226(define (remote-mailbox-host rmb)
     227        (check-remote-mailbox 'remote-mailbox-host rmb)
     228        (%remote-mailbox-host rmb) )
     229
     230(define (remote-mailbox-port rmb)
     231        (check-remote-mailbox 'remote-mailbox-port rmb)
     232        (%remote-mailbox-port rmb) )
     233
     234(define (remote-mailbox-connected? rmb)
     235        (check-remote-mailbox 'remote-mailbox-connected? rmb)
     236        (->boolean (%remote-mailbox-output-port rmb)) )
     237
     238(define (drop-remote-mailbox! rmb)
     239        (check-valid-remote-mailbox 'drop-remote-mailbox! rmb)
     240        (let ([mutex (%remote-mailbox-mutex rmb)])
    224241                (synch mutex
    225                         (close-remote-mailbox-connection! rch)
     242                        (close-remote-mailbox-connection! rmb)
    226243                        (%let/synch ([n->o fullname->remote-mailbox])
    227244                                (dict-delete! n->o (mutex-specific mutex)) ) ) ) )
     
    231248        (set! fullname->remote-mailbox (make-remote-mailbox-mutex)) )
    232249
    233 (define (remote-mailbox-send! rch obj)
    234         (check-valid-remote-mailbox rch 'remote-mailbox-send!)
    235         (synch (%remote-mailbox-mutex rch)
    236                 (let-values ([(in out) (get-connection rch)])
    237                         (serialize (make-remote-mailbox-packet rch obj) out (remote-mailbox-serializer)) ) ) )
     250(define (remote-mailbox-send! rmb obj)
     251        (check-valid-remote-mailbox 'remote-mailbox-send! rmb)
     252        (synch (%remote-mailbox-mutex rmb)
     253                (let-values ([(in out) (get-connection rmb)])
     254                        (serialize (make-remote-mailbox-packet rmb obj) out (remote-mailbox-serializer)) ) ) )
    238255
    239256;;; Server Side
     257
     258;; Parameters
    240259
    241260(define-parameter remote-mailbox-deserializer
    242261  #f
    243262  (lambda (x)
    244         (cond
    245                 [(procedure? x) x]
    246                 [(not x) #f]
    247                 [else (remote-mailbox-deserializer)]) ) )
     263        (cond [(procedure? x)   x]
     264          [(not x)          #f]
     265          [else             (remote-mailbox-deserializer)]) ) )
    248266
    249267(define-parameter remote-mailbox-listen-procedure
     
    251269  (lambda (x)
    252270        (if (procedure? x)
    253                 x
    254                 (remote-mailbox-listen-procedure)) ) )
     271        x
     272        (remote-mailbox-listen-procedure)) ) )
     273
     274;; Support
    255275
    256276(define (remote-mailbox-server)
    257277        (let ([req (deserialize (current-input-port) (remote-mailbox-deserializer))])
    258278                (unless (undefined? req)
    259                         (cond
    260                                 [(remote-mailbox-packet? req)
    261                                         (mailbox-send!
    262                                                 (get-local-mailbox (remote-mailbox-packet-mailbox-name req) #t)
    263                                                 (remote-mailbox-packet-mailbox-value req))]
    264                                 [else
    265                                         (signal
    266             (make-remote-mailbox-exception 'remote-mailbox-server
    267               "request from remote mailbox client not understood"
    268               req))])) )
     279                        (cond [(remote-mailbox-packet? req)
     280              (mailbox-send!
     281               (get-local-mailbox (remote-mailbox-packet-mailbox-name req) #t)
     282               (remote-mailbox-packet-mailbox-value req))]
     283            [else
     284              (signal
     285               (make-remote-mailbox-exception 'remote-mailbox-server
     286                "request from remote mailbox client not understood"
     287                req))])) )
    269288                (remote-mailbox-server) )
    270289
     
    274293(define name->mailbox (make-dict-unique/synch 'name->mailbox))
    275294
     295;; Exported
     296
    276297(define (get-local-mailbox name #!optional (create? #t))
    277         (check-mailbox-name name 'get-local-mailbox)
     298        (check-mailbox-name 'get-local-mailbox name)
    278299        (%let/synch ([n->o name->mailbox])
    279300                (or (dict-ref n->o name)
    280                                 (if create?
    281                                         (let ([ch (make-mailbox name)])
    282                                                 (dict-set! n->o name ch)
    283                                                 ch )
    284                                         #f)) ) )
     301                                (and create?
     302             (let ([ch (make-mailbox name)])
     303               (dict-set! n->o name ch)
     304               ch ) ) ) ) )
    285305
    286306(define (drop-local-mailbox! name)
     
    289309
    290310(define (make-remote-mailbox-server #!optional (port (default-remote-mailbox-port)))
    291         (check-port port 'make-remote-mailbox-server)
     311        (check-port 'make-remote-mailbox-server port)
    292312        (%make-remote-mailbox-server ((remote-mailbox-listen-procedure) port)) )
    293313
     
    296316                (lambda (#!optional (port (default-remote-mailbox-port)))
    297317                        (unless server
    298                                 (check-port port 'run-remote-mailbox-server)
     318                                (check-port 'run-remote-mailbox-server port)
    299319                                (let ([listener ((remote-mailbox-listen-procedure) port)])
    300320                                        (set! server
    301                                                 (make-thread
    302                                                         (cute (%make-remote-mailbox-server listener) "remote-mailbox-server")
    303                                                         'remote-mailbox-server))
     321                                                    (make-thread
     322                                                           (cute (%make-remote-mailbox-server listener) "remote-mailbox-server")
     323                                                           'remote-mailbox-server))
    304324                                        (thread-specific-set! server listener)
    305325                                        (thread-start! server)))
  • release/3/remote-mailbox/trunk/tests/remote-mailbox-test.scm

    r8938 r11636  
    11 ;;;; remote-mailbox-test.scm
     2 
     3 ;; The "server" MUST be started before the client!
    24
    35(use srfi-1 posix srfi-18)
    46(use remote-mailbox mailbox miscmacros)
    57
     8(define-constant NUM-MSG 5)
     9(define-constant RCV-NAM "Wong Foo")
     10
    611(define (client)
    7         (print "Client")
    8         (let ([rch (get-remote-mailbox 'foo)])
    9                 (dotimes (n 5)
    10                         (printf "Send ~A~%" n)
    11                         (remote-mailbox-send! rch (list "To Wong Foo: " n))
     12  (print "* Client - Sending " NUM-MSG " messages")
     13        (let ([rmb (get-remote-mailbox 'foo)])
     14                (dotimes (n NUM-MSG)
     15                        (printf "Sending message number ~A to ~A~%" n RCV-NAM)
     16                        (remote-mailbox-send! rmb (list "to" RCV-NAM ":" n))
     17                        ; Semblance of computation
    1218                        (thread-sleep! 1) )
    1319                (print "Send quit")
    14                 (remote-mailbox-send! rch 'quit) ) )
     20                (remote-mailbox-send! rmb 'quit) ) )
    1521       
    1622(define (server)
    17         (print "Server")
     23  (print "* Server - Receiving messages until 'quit")
    1824        (run-remote-mailbox-server)
    1925        (thread-start!
    2026                (lambda ()
    2127                        (let loop ([msg (mailbox-receive! (get-local-mailbox 'foo))])
    22                                 (printf "Received ~A~%" msg)
     28                                (print "Received " msg)
    2329                                (if (eq? 'quit msg)
    24                                         (exit 0)
    25                                         (loop (mailbox-receive! (get-local-mailbox 'foo))) ) ) ))
     30            (exit 0)
     31            (loop (mailbox-receive! (get-local-mailbox 'foo))) ) ) ))
    2632        (thread-join! (run-remote-mailbox-server)) )
    2733
    2834(define operation
    2935        (let ([args (command-line-arguments)])
    30                 (and (pair? args) (string->symbol (car args))) ) )
     36                (and (pair? args)
     37                     (string->symbol (car args))) ) )
    3138
    3239(if operation
    33         (switch operation
    34                 ['client
    35                         (client)]
    36                 ['server
    37                         (server)]
    38                 [else
    39                         (printf "Unrecognized operation: ~A~%" operation)
    40                         (exit 1)] )
    41         (let ([cmd (first (argv))])
    42                 (process-run cmd `("server"))
    43                 (sleep 1)
    44                 (process-execute cmd `("client")) ) )
     40    (select operation
     41      [('client)
     42        (client)]
     43      [('server)
     44        (server)]
     45      [else
     46        (error 'remote-mailbox-test "Unrecognized operation: " operation) ] )
     47    (let ([cmd (first (argv))])
     48      (process-run cmd `("server"))
     49      #;(sleep 1)
     50      (process-execute cmd `("client")) ) )
Note: See TracChangeset for help on using the changeset viewer.