source: project/release/4/remote-mailbox/trunk/remote-mailbox-common.scm @ 19860

Last change on this file since 19860 was 19860, checked in by kon, 9 years ago

Uses condition-utils. Client params gen warning for bad arg.

File size: 1.7 KB
Line 
1;;;; remote-mailbox-common.scm
2;;;; Kon Lovett, Sep '09
3
4(module remote-mailbox-common
5
6  (;export
7    ;;
8    mailbox-name?
9    tcp-port?
10    hostname?
11    error-mailbox-name
12    error-tcp-port
13    error-hostname
14    check-mailbox-name
15    check-tcp-port
16    check-hostname
17    ;;
18    make-remote-mailbox-packet
19    remote-mailbox-packet?
20    remote-mailbox-packet-key
21    remote-mailbox-packet-value
22    ;;
23    default-remote-mailbox-tcp-port
24    default-remote-mailbox-hostname)
25
26  (import
27    scheme
28    chicken
29    (only srfi-13 string-null?)
30    (only miscmacros define-parameter)
31    (only type-checks define-check+error-type))
32
33  (require-library srfi-13 miscmacros type-checks)
34
35;;;
36
37(define mailbox-name? symbol?)
38
39(define (tcp-port? obj) (and (fixnum? obj) (and (fx< 0 obj) (fx< obj 65536))))
40
41(define (hostname? obj) (and (string? obj) (not (string-null? obj))))
42
43;;;
44
45(define-check+error-type mailbox-name)
46(define-check+error-type hostname)
47(define-check+error-type tcp-port)
48
49;;; Remote Mailbox Packet
50
51(define +remote-mailbox-tag+ 'rmbtag)
52
53(define (make-remote-mailbox-packet key val) (vector +remote-mailbox-tag+ key val))
54
55(define (remote-mailbox-packet? obj)
56        (and (vector? obj)
57                         (= 3 (vector-length obj))
58                         (eq? +remote-mailbox-tag+ (vector-ref obj 0))) )
59
60(define (remote-mailbox-packet-key rmp) (vector-ref rmp 1))
61
62(define (remote-mailbox-packet-value rmp) (vector-ref rmp 2))
63
64;;; Parameters
65
66(define-parameter default-remote-mailbox-tcp-port 63001
67        (lambda (x)
68                (cond ((tcp-port? x) x)
69          (else (default-remote-mailbox-tcp-port) ) ) ) )
70
71(define-parameter default-remote-mailbox-hostname "localhost"
72        (lambda (x)
73                (cond ((hostname? x) x)
74          (else (default-remote-mailbox-hostname) ) ) ) )
75
76) ;module remote-mailbox-common
77
Note: See TracBrowser for help on using the repository browser.