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

mv serialize to adapter module

File:
1 edited

Legend:

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

    r19860 r33908  
    88(module remote-mailbox-client
    99
    10   (;export
    11     ;; Common
    12     ; Parameters
    13     default-remote-mailbox-tcp-port
    14     default-remote-mailbox-hostname
    15     ;; Client
    16     ; Parameters
    17     default-remote-mailbox-connect
    18     default-remote-mailbox-serializer
    19     ; Operations
    20     remote-mailbox
    21     remote-mailbox?
    22     remote-mailbox-name
    23     remote-mailbox-hostname
    24     remote-mailbox-tcp-port
    25     remote-mailbox-connected?
    26     drop-remote-mailbox!
    27     drop-remote-mailboxes!
    28     remote-mailboxes
    29     remote-mailbox-send!)
     10(;export
     11  ;; Common
     12  ; Parameters
     13  default-remote-mailbox-tcp-port
     14  default-remote-mailbox-hostname
     15  ;; Client
     16  ; Parameters
     17  default-remote-mailbox-connect
     18  ; Operations
     19  remote-mailbox
     20  remote-mailbox?
     21  remote-mailbox-name
     22  remote-mailbox-hostname
     23  remote-mailbox-tcp-port
     24  remote-mailbox-connected?
     25  drop-remote-mailbox!
     26  drop-remote-mailboxes!
     27  remote-mailboxes
     28  remote-mailbox-send!)
    3029
    31   (import
    32     scheme
    33     chicken
    34     tcp
    35     (only srfi-18 make-mutex mutex-name)
    36     (only data-structures conc)
    37     (only miscmacros define-parameter)
    38     s11n
    39     mailbox
    40     synch
    41     lookup-table-synch
    42     (only type-checks check-procedure define-check+error-type)
    43     (only type-errors warning-argument-type)
    44     remote-mailbox-common)
     30(import scheme chicken)
    4531
    46   (require-library
    47     tcp srfi-18
    48     miscmacros s11n mailbox synch lookup-table-synch
    49     type-checks type-errors
    50     remote-mailbox-common)
     32(import
     33  tcp
     34  (only srfi-18 make-mutex mutex-name)
     35  (only data-structures conc)
     36  (only miscmacros define-parameter)
     37  mailbox
     38  synch
     39  lookup-table-synch
     40  (only type-checks check-procedure define-check+error-type)
     41  (only type-errors warning-argument-type)
     42  remote-mailbox-adapter
     43  remote-mailbox-packet
     44  remote-mailbox-common)
     45(require-library
     46  tcp srfi-18
     47  miscmacros mailbox synch lookup-table-synch
     48  type-checks type-errors
     49  remote-mailbox-adapter
     50  remote-mailbox-packet
     51  remote-mailbox-common)
    5152
    5253;;; Utilities
     
    5758
    5859(define-record-type remote-mailbox
    59         (*make-remote-mailbox name hstnam prtnum connect mutex input output)
    60         *remote-mailbox?
    61         (name remote-mailbox-name remote-mailbox-name-set!)
    62         (hstnam remote-mailbox-hostname)
    63         (prtnum remote-mailbox-tcp-port)
    64         (connect remote-mailbox-connect)
    65         (mutex remote-mailbox-mutex)
    66         (input remote-mailbox-input-port remote-mailbox-input-port-set!)
    67         (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
     60  (*make-remote-mailbox name hstnam prtnum serializer connect mutex input output)
     61  *remote-mailbox?
     62  (name remote-mailbox-name remote-mailbox-name-set!)
     63  (hstnam remote-mailbox-hostname)
     64  (prtnum remote-mailbox-tcp-port)
     65  (serializer remote-mailbox-serializer)
     66  (connect remote-mailbox-connect)
     67  (mutex remote-mailbox-mutex)
     68  (input remote-mailbox-input-port remote-mailbox-input-port-set!)
     69  (output remote-mailbox-output-port remote-mailbox-output-port-set!) )
    6870
    69 (define (invalidate-remote-mailbox! rmb) (remote-mailbox-name-set! rmb #f))
    70 (define (valid-remote-mailbox? rmb) (->boolean (remote-mailbox-name rmb)))
     71(define (invalidate-remote-mailbox! rmb)
     72  (remote-mailbox-name-set! rmb #f) )
    7173
    72 (define (remote-mailbox-key rmb) (mutex-name (remote-mailbox-mutex rmb)))
     74(define (valid-remote-mailbox? rmb)
     75  (->boolean (remote-mailbox-name rmb)) )
     76
     77(define (remote-mailbox-key rmb)
     78  (mutex-name (remote-mailbox-mutex rmb)) )
    7379
    7480(define +remote-mailbox-key->remote-mailbox+ (make-dict/synch))
    7581
    7682(define (make-remote-mailbox-key name hostname tcp-port)
    77         (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
     83  (conc name #\@ hostname (if tcp-port (conc #\: tcp-port) "")) )
    7884
    7985(define (*remote-mailbox name hostname tcp-port connect)
    8086  (let ((key (make-remote-mailbox-key name hostname tcp-port)))
    81     (dict-indempotent-ref!/synch
    82       +remote-mailbox-key->remote-mailbox+
     87    (dict-indempotent-ref!/synch +remote-mailbox-key->remote-mailbox+
    8388      key
    8489      (lambda (def)
    85         (*make-remote-mailbox name hostname tcp-port connect (make-mutex key) #f #f))) ) )
     90        (*make-remote-mailbox
     91          name
     92          hostname tcp-port
     93          (serializer) connect
     94          (make-mutex key) #f #f))) ) )
    8695
    87 (define (*remote-mailbox-connected? rmb) (->boolean (remote-mailbox-output-port rmb)))
     96(define (*remote-mailbox-connected? rmb)
     97  (->boolean (remote-mailbox-output-port rmb)) )
    8898
    8999(define (connection/remote-mailbox rmb)
    90         (if (*remote-mailbox-connected? rmb) (remote-mailbox-output-port rmb)
    91       ; else make a connection
    92       (let-values (((in out)
    93                     (let ((connect (remote-mailbox-connect rmb))
    94                           (tcp-port (remote-mailbox-tcp-port rmb)) )
    95                       ; Allow hostname to carry service/portno
    96                       (if (not tcp-port) (connect (remote-mailbox-hostname rmb))
    97                           (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
    98         (remote-mailbox-input-port-set! rmb in)
    99         (remote-mailbox-output-port-set! rmb out)
    100         out )) )
     100  (if (*remote-mailbox-connected? rmb)
     101    (remote-mailbox-output-port rmb)
     102    ; else make a connection
     103    (let-values (
     104        ((in out)
     105          (let ((connect (remote-mailbox-connect rmb))
     106                (tcp-port (remote-mailbox-tcp-port rmb)) )
     107            ; Allow hostname to carry service/portno
     108            (if (not tcp-port)
     109              (connect (remote-mailbox-hostname rmb))
     110              (connect (remote-mailbox-hostname rmb) tcp-port) ) ) ) )
     111      (remote-mailbox-input-port-set! rmb in)
     112      (remote-mailbox-output-port-set! rmb out)
     113      out )) )
    101114
    102115(define (close-remote-mailbox-connection! rmb)
    103116  (close-input-port (remote-mailbox-input-port rmb))
    104         (remote-mailbox-input-port-set! rmb #f)
    105         (close-output-port (remote-mailbox-output-port rmb))
    106         (remote-mailbox-output-port-set! rmb #f)
    107         (invalidate-remote-mailbox! rmb) )
     117  (remote-mailbox-input-port-set! rmb #f)
     118  (close-output-port (remote-mailbox-output-port rmb))
     119  (remote-mailbox-output-port-set! rmb #f)
     120  (invalidate-remote-mailbox! rmb) )
    108121
    109122(define (*drop-remote-mailbox! rmb)
    110         (record/synch remote-mailbox rmb
     123  (record/synch remote-mailbox rmb
    111124    (close-remote-mailbox-connection! rmb)
    112     (dict-delete!/synch +remote-mailbox-key->remote-mailbox+ (remote-mailbox-key rmb)) ) )
     125    (dict-delete!/synch +remote-mailbox-key->remote-mailbox+
     126      (remote-mailbox-key rmb)) ) )
    113127
    114128(define-check+error-type remote-mailbox)
     
    118132;; Parameters
    119133
    120 (define-parameter default-remote-mailbox-serializer #f
    121   (lambda (x)
    122         (cond
    123           ((procedure? x) x)
    124       ((not x)        #f)
    125       (else
    126         (warning-argument-type 'default-remote-mailbox-serializer x 'procedure)
    127         (default-remote-mailbox-serializer))) ) )
    128 
    129134(define-parameter default-remote-mailbox-connect tcp-connect
    130135  (lambda (x)
    131         (cond
    132           ((procedure? x) x)
     136    (cond
     137      ((procedure? x)
     138        x )
     139      ((not x)
     140        tcp-connect )
    133141      (else
    134142        (warning-argument-type 'default-remote-mailbox-connect x 'procedure)
     
    137145;; Operations
    138146
    139 (define (remote-mailbox name #!key (hostname (default-remote-mailbox-hostname))
    140                                    (tcp-port (default-remote-mailbox-tcp-port))
    141                                    (connect (default-remote-mailbox-connect)))
    142         (check-mailbox-name 'remote-mailbox name 'name)
    143         (check-hostname 'remote-mailbox hostname 'hostname)
    144         (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
    145         (check-procedure 'remote-mailbox connect 'connect)
    146         (*remote-mailbox name hostname tcp-port connect) )
     147(define (remote-mailbox name
     148          #!key
     149          (hostname (default-remote-mailbox-hostname))
     150          (tcp-port (default-remote-mailbox-tcp-port))
     151          (connect (default-remote-mailbox-connect)))
     152  (check-mailbox-name 'remote-mailbox name 'name)
     153  (check-hostname 'remote-mailbox hostname 'hostname)
     154  (when tcp-port (check-tcp-port 'remote-mailbox tcp-port 'tcp-port))
     155  (check-procedure 'remote-mailbox connect 'connect)
     156  (*remote-mailbox name hostname tcp-port connect) )
    147157
    148158(define (remote-mailbox? obj)
    149         (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
     159  (and (*remote-mailbox? obj) (valid-remote-mailbox? obj)) )
    150160
    151161(define (remote-mailbox-connected? rmb)
    152         (check-remote-mailbox 'remote-mailbox-connected? rmb)
    153         (*remote-mailbox-connected? rmb) )
     162  (check-remote-mailbox 'remote-mailbox-connected? rmb)
     163  (*remote-mailbox-connected? rmb) )
    154164
    155165(define (remote-mailboxes)
    156         (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
     166  (dict-values/synch +remote-mailbox-key->remote-mailbox+) )
    157167
    158168(define (drop-remote-mailbox! rmb)
    159         (check-remote-mailbox 'drop-remote-mailbox! rmb)
    160         (*drop-remote-mailbox! rmb) )
     169  (check-remote-mailbox 'drop-remote-mailbox! rmb)
     170  (*drop-remote-mailbox! rmb) )
    161171
    162172(define (drop-remote-mailboxes!)
    163173  (for-each (cut *drop-remote-mailbox! <>) (remote-mailboxes)) )
    164174
    165 (define (remote-mailbox-send! rmb val #!optional (serializer (default-remote-mailbox-serializer)))
    166         (check-remote-mailbox 'remote-mailbox-send! rmb)
    167         (when serializer (check-procedure 'remote-mailbox serializer 'serializer))
    168         (record/synch remote-mailbox rmb
    169                 (let ((out (connection/remote-mailbox rmb))
    170                       (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
    171                         (serialize req out serializer) ) ) )
     175(define (remote-mailbox-send! rmb val)
     176  (check-remote-mailbox 'remote-mailbox-send! rmb)
     177  (record/synch remote-mailbox rmb
     178    (let ((out (connection/remote-mailbox rmb))
     179          (req (make-remote-mailbox-packet (remote-mailbox-name rmb) val)) )
     180      (parameterize ((serializer (remote-mailbox-serializer rmb)))
     181        (serialize req out) ) ) ) )
    172182
    173183) ;module remote-mailbox-client
Note: See TracChangeset for help on using the changeset viewer.