Changeset 15814 in project


Ignore:
Timestamp:
09/09/09 07:24:35 (10 years ago)
Author:
iraikov
Message:

smtp save

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/smtp/trunk/smtp.scm

    r15800 r15814  
    6969        (import scheme chicken data-structures )
    7070
    71         (require-library extras abnf)
    72         (import (prefix abnf abnf:) (only extras sprintf fprintf ))
     71        (require-library extras abnf abnf-consumers)
     72        (import (prefix abnf abnf:)
     73                (prefix abnf-consumers abnf:)
     74                (only extras sprintf fprintf ))
    7375
    7476        (require-extension srfi-1 srfi-13 srfi-14 datatype matchable )
    7577        (import-for-syntax matchable)
    7678
    77 ;; construct strings from consumed chars
    78 (define scollect (abnf:collect-chars list->string))
    79 
    80 (define (trim-ws-char-list cs)
    81   (let* ((cs1 (let loop ((cs cs))
    82                (cond ((null? cs) (reverse cs))
    83                      ((char-set-contains? char-set:whitespace (car cs))
    84                       (loop (cdr cs)))
    85                      (else (reverse cs)))))
    86          (cs2  (let loop ((cs cs1))
    87                (cond ((null? cs) (reverse cs))
    88                      ((char-set-contains? char-set:whitespace (car cs))
    89                       (loop (cdr cs)))
    90                      (else (reverse cs))))))
    91     cs2))
    92    
    93 
    94 ;; construct symbols from consumed chars; trailing and preceding white
    95 ;; space is stripped
    96 (define sscollect
    97   (abnf:collect-chars
    98    (compose string->symbol list->string trim-ws-char-list)))
    99 
    100 ;; collects all consumed objects of type obj?
    101 (define (consumed-objects obj?)
    102   (lambda (cs)
    103     (and (pair? cs)
    104          (let loop ((cs cs) (ax (list)))
    105            (cond ((null? cs)   (list ax ))
    106                  ((obj? (car cs))
    107                   (loop (cdr cs) (cons (car cs) ax)))
    108                  (else (cons ax cs)))))))
    109 
    110 ;; construct lists from consumed objects
    111 (define (lcollect obj?)
    112   (let ((get-consumed (consumed-objects obj?)))
    113     (lambda rest
    114       (let-optionals rest ((kons identity))
    115         (let ((make (if (procedure? kons) kons (lambda (x) `(,kons . ,x)))))
    116           (lambda (x)
    117             (let ((x1 (get-consumed x)))
    118               (and x1 (pair? (car x1)) (cons (make (car x1)) (cdr x1))))))))))
    119 
    120 
    121 ;; shortcut for (abnf:bind (abnf:collect-chars) (abnf:longest ... ))
    122 (define-syntax consumed->list
    123   (syntax-rules ()
    124     ((_ p)      (abnf:bind (abnf:collect-chars) (abnf:longest p)))
    125     ((_ l p)    (abnf:bind (abnf:collect-chars l) (abnf:longest p)))
    126     ))
    127 
    128 ;; shortcut for (abnf:bind scollect (abnf:longest ... ))
    129 (define-syntax consumed->string
    130   (syntax-rules ()
    131     ((_ p)    (abnf:bind scollect (abnf:longest p)))
    132     ))
     79(define consumed-objects-lift-any
     80  (abnf:consumed-objects-lift
     81   (abnf:consumed-objects identity)))
    13382
    13483(define (list->domain-string lst)
     
    13887      (list->string lst)))
    13988
    140 (define-syntax consumed->domain-string
     89(define-syntax bind-consumed->domain-string
    14190  (syntax-rules ()
    142     ((_ p)    (abnf:bind (abnf:collect-chars list->domain-string)
    143                          (abnf:longest p)))
     91    ((_ p)    (abnf:bind
     92               (abnf:consumed-chars->list list->domain-string)
     93               (abnf:longest p)))
    14494    ))
    14595
    146 ;; shortcut for (abnf:bind sscollect (abnf:longest ... ))
    147 (define-syntax consumed->symbol
    148   (syntax-rules ()
    149     ((_ p)    (abnf:bind sscollect (abnf:longest p)))
    150     ))
    151 
    152 (define lcollect-strings (lcollect string?))
    153 
    154 ;; shortcut for (abnf:bind (lcollect-strings ...) (abnf:longest ... ))
    155 (define-syntax consumed-strings->list
    156   (syntax-rules ()
    157     ((_ l p)    (abnf:bind (lcollect-strings l)  (abnf:longest p)))
    158     ((_ p)      (abnf:bind (lcollect-strings)    (abnf:longest p)))
    159     ))
    160 
    161 (define lcollect-pairs  (lcollect pair?))
    162 
    163 ;; shortcut for (abnf:bind (lcollect-pairs ...) (abnf:longest ... ))
    164 (define-syntax consumed-pairs->list
    165   (syntax-rules ()
    166     ((_ l p)    (abnf:bind (lcollect-pairs l)  (abnf:longest p)))
    167     ((_ p)      (abnf:bind (lcollect-pairs)    (abnf:longest p)))
    168     ))
    16996
    17097(define-syntax define-enumerated-type
     
    196123
    197124(define-datatype mailbox mailbox?
    198   (Mailbox (local-part string?) (domain string?)))
     125  (Mailbox (local-part string?)
     126           (domain string?)
     127           (parameters list?)))
    199128
    200129(define-record-printer (mailbox x out)
     
    206135            (fprintf out "<~S>" mbox)))))
    207136
    208 (define (null-path) (Mailbox "" ""))
    209 
    210 (define (postmaster) (Mailbox "postmaster" ""))
     137(define (null-path) (Mailbox "" "" '()))
     138
     139(define (postmaster) (Mailbox "postmaster" "" '()))
    211140
    212141
     
    333262               (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
    334263
    335 (define Atom         (consumed->string (abnf:repetition1 atext)))
    336 
    337 (define Dot-string   (consumed->string
     264(define Atom         (abnf:bind-consumed->string (abnf:repetition1 atext)))
     265
     266(define Dot-string   (abnf:bind-consumed->string
    338267                      (abnf:concatenation
    339268                       (abnf:repetition1 atext)
     
    358287(define QcontentSMTP     (abnf:alternatives qtextSMTP quoted-pairSMTP))
    359288
    360 (define Quoted-string    (consumed->string
     289(define Quoted-string    (abnf:bind-consumed->string
    361290                          (abnf:concatenation
    362291                           (abnf:drop-consumed abnf:dquote)
     
    366295(define String           (abnf:alternatives Atom Quoted-string))
    367296
    368 (define esmtp-keyword   (consumed->symbol
     297(define esmtp-keyword   (abnf:bind-consumed->symbol
    369298                         (abnf:concatenation
    370299                          (abnf:alternatives abnf:alpha abnf:decimal)
     
    375304                            (abnf:char #\-))))))
    376305
    377 (define esmtp-value    (consumed->string
     306(define esmtp-value    (abnf:bind-consumed->string
    378307                        (abnf:repetition1
    379308                         (abnf:set (char-set-difference
     
    384313;; SHOULD be used.
    385314
    386 (define esmtp-param     (consumed-strings->list
     315(define esmtp-param     (abnf:bind-consumed-strings->list
    387316                         (abnf:concatenation
    388317                          esmtp-keyword
     
    394323
    395324
    396 (define Mail-parameters  (consumed-pairs->list
     325(define Mail-parameters  (abnf:bind-consumed-pairs->list
    397326                          (abnf:concatenation
    398327                           esmtp-param
    399328                           (abnf:repetition
    400329                            (abnf:concatenation
    401                              (abnf:drop-consumed abnf:sp) esmtp-param)))))
     330                             (abnf:drop-consumed abnf:sp)
     331                             esmtp-param)))))
    402332
    403333(define Rcpt-parameters  Mail-parameters)
     
    405335(define Argument       Atom)
    406336
    407 (define Ldh-str        (consumed->domain-string
     337(define Ldh-str        (bind-consumed->domain-string
    408338                        (abnf:concatenation
    409339                         abnf:alpha
     
    414344(define sub-domain     Ldh-str)
    415345
    416 (define domain         (consumed-strings->list
     346(define domain         (abnf:bind-consumed-strings->list
     347                        (lambda (l)
     348                          (string-concatenate (intersperse l ".")))
    417349                        (abnf:concatenation
    418350                         sub-domain
     
    437369                      Quoted-string))
    438370
    439 (define IPv6-hex     (consumed->string
     371(define IPv6-hex     (abnf:bind-consumed->string
    440372                      (abnf:variable-repetition 1 4 abnf:hexadecimal)))
    441373
     
    444376                      IPv6-hex))
    445377
    446 (define IPv6-full    (consumed-strings->list
     378(define IPv6-full    (abnf:bind-consumed-strings->list
    447379                      (abnf:concatenation
    448380                       IPv6-hex
    449381                       (abnf:repetition-n 7 cIPv6-hex))))
    450382
    451 (define IPv6-comp    (consumed-strings->list
     383(define IPv6-comp    (abnf:bind-consumed-strings->list
    452384                      (abnf:concatenation
    453385                       (abnf:optional-sequence
     
    455387                         IPv6-hex
    456388                         (abnf:variable-repetition 0 5 cIPv6-hex)))
    457                        (consumed->string (abnf:lit "::"))
     389                       (abnf:bind-consumed->string (abnf:lit "::"))
    458390                       (abnf:optional-sequence
    459391                        (abnf:concatenation
     
    463395;; than 6 groups in addition to the "::" may be present.
    464396
    465 (define Snum        (consumed->string (abnf:variable-repetition 1 3 abnf:decimal)))
     397(define Snum       
     398  (abnf:bind-consumed->string
     399   (abnf:variable-repetition 1 3 abnf:decimal)))
    466400
    467401(define IPv4-address-literal  (abnf:concatenation
     
    472406                                   Snum))))
    473407
    474 (define IPv6v4-full   (consumed-strings->list
     408(define IPv6v4-full   (abnf:bind-consumed-strings->list
    475409                       (abnf:concatenation
    476410                        IPv6-hex (abnf:repetition-n 5 cIPv6-hex)
     
    478412                        IPv4-address-literal)))
    479413
    480 (define IPv6v4-comp   (consumed-strings->list
     414(define IPv6v4-comp   (abnf:bind-consumed-strings->list
    481415                       (abnf:concatenation
    482416                        (abnf:optional-sequence
     
    484418                          IPv6-hex
    485419                          (abnf:variable-repetition 0 3 cIPv6-hex)))
    486                         (consumed->string (abnf:lit "::"))
     420                        (abnf:bind-consumed->string (abnf:lit "::"))
    487421                        (abnf:optional-sequence
    488422                         (abnf:concatenation
     
    499433
    500434(define IPv6-address-literal  (abnf:concatenation
    501                                (consumed->string (abnf:lit "IPv6:")) IPv6-addr))
     435                               (abnf:bind-consumed->string (abnf:lit "IPv6:")) IPv6-addr))
    502436
    503437(define dcontent  (abnf:set (char-set-difference
     
    505439                             (char-set #\[ #\] #\\))))
    506440
    507 (define Standardized-tag  (consumed->symbol Ldh-str))
     441(define Standardized-tag  (abnf:bind-consumed->symbol Ldh-str))
    508442;; Standardized-tag MUST be specified in a Standards-Track RFC and
    509443;; registered with IANA
     
    522456;; See Section 4.1.3
    523457
    524 (define Mailbox        (abnf:concatenation Local-part (abnf:char #\@) (abnf:alternatives domain address-literal)))
    525 
    526 (define Path           (abnf:concatenation (abnf:char #\<)
    527                                            (abnf:optional-sequence (abnf:concatenation A-d-l (abnf:char #\:)))
    528                                            Mailbox (abnf:char #\>)))
     458(define Mailbox-p
     459  (abnf:bind
     460   (consumed-objects-lift-any
     461    (lambda (x) (Mailbox (first x) (second x))))
     462   (abnf:concatenation
     463    Local-part
     464    (abnf:drop-consumed (abnf:char #\@) )
     465    (abnf:alternatives domain address-literal))))
     466
     467(define Path
     468  (abnf:concatenation
     469   (abnf:drop-consumed (abnf:char #\<) )
     470   (abnf:optional-sequence
     471    (abnf:concatenation A-d-l (abnf:char #\:)))
     472   Mailbox-p
     473   (abnf:drop-consumed (abnf:char #\>))))
     474
    529475(define Forward-path   Path)
    530476
    531477(define Reverse-path
    532478  (abnf:alternatives
    533    Path (abnf:concatenation (abnf:char #\<) (abnf:char #\>))))
     479   Path
     480   (abnf:concatenation
     481    (abnf:char #\<) (abnf:char #\>))))
    534482
    535483
    536484(define from-path
    537485  (abnf:concatenation
    538    (abnf:lit "FROM:")
     486   (abnf:drop-consumed (abnf:lit "FROM:"))
    539487   Reverse-path
    540    (abnf:optional-sequence (abnf:concatenation abnf:sp Rcpt-parameters))))
     488   (abnf:optional-sequence
     489    (abnf:concatenation
     490     (abnf:drop-consumed abnf:sp )
     491     Rcpt-parameters))))
    541492   
    542493(define to-path
     
    627578  (define (ignore x) (kons))
    628579  (let ((ss (->string s)))
    629     (abnf:bind ((lcollect ignore))
     580    (abnf:bind (consumed-objects-lift-any ignore)
    630581     (abnf:concatenation
    631       (consumed->symbol (abnf:lit ss))
     582      (abnf:bind-consumed->symbol (abnf:lit ss))
    632583      (abnf:drop-consumed (abnf:repetition abnf:sp))
    633584      (abnf:drop-consumed abnf:crlf)
     
    636587;; Constructs a WrongArg command
    637588(define (wrong-arg cmd)
    638   (abnf:bind (lambda (x) (WrongArg cmd ""))
     589  (abnf:bind (lambda (x) (list (WrongArg cmd "")))
    639590             abnf:pass))
    640591
     
    649600      (print "mkcmdp1: s = " s)
    650601      ((abnf:concatenation
    651         (lambda (cont s)
    652           (print "mkcmdp1: header s = " s)
    653           ((consumed->symbol (abnf:lit ss))
    654            (lambda (x) (print "mkcmdp1: header = " x) (cont x))
    655            s))
    656         (abnf:repetition abnf:sp)
     602        (abnf:drop-consumed
     603         (lambda (cont s)
     604           (print "mkcmdp1: header s = " s)
     605           ((abnf:lit ss)
     606            (lambda (x) (print "mkcmdp1: header = " x) (cont x))
     607            s)))
     608        (abnf:drop-consumed (abnf:repetition abnf:sp))
    657609        (abnf:alternatives
    658          (abnf:bind (abnf:collect-chars (compose kons list->string)) p)
     610         (abnf:bind (consumed-objects-lift-any
     611                     (lambda (x) (kons (first x)))) p)
    659612         (wrong-arg ss) )
    660613        (abnf:drop-consumed abnf:crlf))
Note: See TracChangeset for help on using the changeset viewer.