Changeset 15280 in project


Ignore:
Timestamp:
07/31/09 07:26:18 (10 years ago)
Author:
Ivan Raikov
Message:

fixes in smtp

File:
1 edited

Legend:

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

    r15133 r15280  
    6767;; construct symbols from consumed chars; trailing and preceding white
    6868;; space is stripped
    69 (define sscollect (abnf:collect-chars (compose string->symbol list->string trim-ws-char-list)))
     69(define sscollect
     70  (abnf:collect-chars
     71   (compose string->symbol list->string trim-ws-char-list)))
    7072
    7173;; collects all consumed objects of type obj?
     
    111113        (,%define (,pred x)    (##sys#structure? x ',typename))
    112114        (,%define (,project x) (##sys#slot x 2))
    113         (,%define (,inject i)  (and (integer? i) (positive? i) (< i (vector-length ,vector))
    114                                     (vector-ref ,vector i)))
     115        (,%define (,inject i) 
     116                  (and (integer? i) (positive? i) (< i (vector-length ,vector))
     117                       (vector-ref ,vector i)))
    115118        ,(let loop ((variants rest) (i 0) (defs (list)))
    116119           (if (null? variants)
    117120               `(,%begin ,@defs)
    118121               (let* ((variant  (car variants))
    119                       (def  `(,%define ,variant   (##sys#make-structure ',typename ',(car variant) ,i))))
     122                      (def  `(,%define ,variant   
     123                                       (##sys#make-structure ',typename ',(car variant) ,i))))
    120124                 (loop (cdr variants) (+ i 1) (cons def defs)))))
    121125        ,(let loop ((variants rest) (defs (list)))
     
    128132
    129133(define-datatype mailbox mailbox?
    130   (Mailbox (route list?) (local-part string?) (domain string?)))
     134  (Mailbox (local-part string?) (domain string?)))
    131135
    132136(define-record-printer (mailbox x out)
    133137  (match x
    134          (($ mailbox 'Mailbox () "" "" )  (fprintf out "<>"))
    135          (($ mailbox 'Mailbox () "postmaster" "" )  (fprintf out "<postmaster>"))
    136          (($ mailbox 'Mailbox r l d ) 
    137           (let ((route (string-concatenate (intersperse r ",")))
    138                 (mbox  (sprintf "~S@~S" l d)))
    139             (if (string-null? route) (fprintf out "<~S>" mbox)
    140                 (fprintf out "<~S:~S>" route mbox))))))
    141 
    142 (define (null-path) (Mailbox (list) "" ""))
    143 
    144 (define (postmaster) (Mailbox (list) "postmaster" ""))
     138         (($ mailbox 'Mailbox "" "" )  (fprintf out "<>"))
     139         (($ mailbox 'Mailbox "postmaster" "" )  (fprintf out "<postmaster>"))
     140         (($ mailbox 'Mailbox l d ) 
     141          (let ((mbox  (sprintf "~S@~S" l d)))
     142            (fprintf out "<~S>" mbox)))))
     143
     144(define (null-path) (Mailbox "" ""))
     145
     146(define (postmaster) (Mailbox "postmaster" ""))
    145147
    146148
     
    205207  (cases code x
    206208         (Code (suc cat n) 
    207                (fprintf out "~A~A~A" (success-code-project suc) (category-project cat) n))))
     209               (fprintf out "~A~A~A" (success-code-project suc)
     210                        (category-project cat) n))))
    208211         
    209212;; Constructs a Reply.
     
    228231  (match r (($ reply 'Reply
    229232               ($ code 'Code
    230                   ($ success-code (or 'PreliminarySuccess 'IntermediateSuccess 'Success _) _ _) _))
     233                  ($ success-code (or 'PreliminarySuccess
     234                                      'IntermediateSuccess 'Success _) _ _) _))
    231235            #t)
    232236         (else #f)))
     
    238242  (match r (($ reply 'Reply
    239243               ($ code 'Code
    240                   ($ success-code (or 'PermanentFailure 'TransientFailure _) _ _) _))
     244                  ($ success-code (or 'PermanentFailure
     245                                      'TransientFailure _) _ _) _))
    241246            #t)
    242247         (else #f)))
     
    246251(define (reply-shutdown? r)
    247252  (match r (($ reply 'Reply
    248                ($ code 'Code ($ success-code (or 'Success 'TransientFailure) _)
     253               ($ code 'Code ($ success-code (or 'Success
     254                                                 'TransientFailure) _)
    249255                  ($ category 'Connection _) 1) _)
    250256            #t)
     
    262268               (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
    263269
    264 (define Atom        (abnf:repetition1 atext))
    265 
    266 (define Dot-string  (abnf:concatenation Atom (abnf:repetition (abnf:concatenation (abnf:char #\.) Atom))))
     270(define Atom         (consumed->string (abnf:repetition1 atext)))
     271
     272(define Dot-string   (consumed->string
     273                      (abnf:concatenation
     274                       (abnf:repetition1 atext)
     275                       (abnf:repetition
     276                        (abnf:concatenation
     277                         (abnf:char #\.)
     278                         (abnf:repetition1 atext))))))
    267279
    268280;; backslash followed by any ASCII graphic (including itself) or space
    269 (define quoted-pairSMTP  (abnf:concatenation (abnf:char #\\) (abnf:set char-set:printing)))
     281(define quoted-pairSMTP  (abnf:concatenation
     282                          (abnf:char #\\)
     283                          (abnf:set char-set:printing)))
    270284
    271285;; within a quoted string, any ASCII graphic or space is permitted
    272286;; without blackslash-quoting except double-quote and the backslash
    273287;; itself.
    274 (define qtextSMTP        (abnf:set (char-set-difference char-set:printing (char-set #\" #\\))))
     288(define qtextSMTP        (abnf:set
     289                          (char-set-difference
     290                           char-set:printing
     291                           (char-set #\" #\\))))
    275292
    276293(define QcontentSMTP     (abnf:alternatives qtextSMTP quoted-pairSMTP))
    277294
    278 (define Quoted-string    (abnf:concatenation abnf:dquote  (abnf:repetition QcontentSMTP) abnf:dquote))
     295(define Quoted-string    (consumed->string
     296                          (abnf:concatenation
     297                           (abnf:drop-consumed abnf:dquote)
     298                           (abnf:repetition QcontentSMTP)
     299                           (abnf:drop-consumed abnf:dquote))))
    279300
    280301(define String           (abnf:alternatives Atom Quoted-string))
     
    282303(define Let-dig          (abnf:alternatives abnf:alpha abnf:decimal))
    283304
    284 (define esmtp-keyword   (abnf:concatenation (abnf:alternatives abnf:alpha abnf:decimal)
    285                                             (abnf:repetition (abnf:alternatives abnf:alpha abnf:decimal
    286                                                                                 (abnf:char #\-)))))
    287 
    288 (define esmtp-value    (abnf:repetition1
    289                         (abnf:set (char-set-difference
    290                                    char-set:graphic (char-set #\= #\space)))))
     305(define esmtp-keyword   (consumed->symbol
     306                         (abnf:concatenation
     307                          (abnf:alternatives abnf:alpha abnf:decimal)
     308                          (abnf:repetition
     309                           (abnf:alternatives
     310                            abnf:alpha
     311                            abnf:decimal
     312                            (abnf:char #\-))))))
     313
     314(define esmtp-value    (consumed->string
     315                        (abnf:repetition1
     316                         (abnf:set (char-set-difference
     317                                    char-set:graphic (char-set #\= #\space))))))
    291318;; any CHAR excluding "=", SP, and control
    292319;; characters.  If this string is an email address,
     
    294321;; SHOULD be used.
    295322
    296 (define esmtp-param     (abnf:concatenation esmtp-keyword
    297                                             (abnf:optional-sequence (abnf:concatenation (abnf:char #\=) esmtp-value))))
    298 
    299 
    300 (define Mail-parameters  (abnf:concatenation esmtp-param (abnf:repetition (abnf:concatenation abnf:sp esmtp-param))))
     323(define esmtp-param     (consumed-strings->list
     324                         (abnf:concatenation
     325                          esmtp-keyword
     326                          (abnf:optional-sequence
     327                           (abnf:concatenation
     328                            (abnf:drop-consumed (abnf:char #\=))
     329                            esmtp-value)))))
     330
     331
     332
     333(define Mail-parameters  (consumed-pairs->list
     334                          (abnf:concatenation
     335                           esmtp-param
     336                           (abnf:repetition
     337                            (abnf:concatenation
     338                             (abnf:drop-consumed abnf:sp) esmtp-param)))))
    301339
    302340(define Rcpt-parameters  Mail-parameters)
    303341
    304342
    305 (define Ldh-str          (abnf:concatenation
    306                           (abnf:repetition (abnf:alternatives abnf:alpha abnf:decimal (abnf:char #\-)))
     343(define Ldh-str         (abnf:concatenation
     344                          (abnf:repetition
     345                           (abnf:alternatives
     346                            abnf:alpha abnf:decimal (abnf:char #\-)))
    307347                          Let-dig))
     348
    308349(define Keyword        Ldh-str)
    309350(define Argument       Atom)
    310351
    311 (define sub-domain     (abnf:concatenation Let-dig (abnf:optional-sequence Ldh-str)))
    312 
    313 (define Domain         (abnf:concatenation
    314                         sub-domain
    315                         (abnf:repetition
    316                          (abnf:concatenation
    317                           (abnf:char #\.) sub-domain))))
    318 
    319 (define At-domain    (abnf:concatenation (abnf:char #\@) Domain))
    320 
    321 (define A-d-l        (abnf:concatenation At-domain (abnf:repetition (abnf:concatenation (abnf:char #\,) At-domain))))
    322 
    323 (define Local-part   (abnf:alternatives Dot-string Quoted-string))
    324 
    325 (define IPv6-hex     (abnf:variable-repetition 1 4 abnf:hexadecimal))
    326 
    327 (define cIPv6-hex    (abnf:concatenation (abnf:char #\:) IPv6-hex))
    328 
    329 (define IPv6-full    (abnf:concatenation IPv6-hex (abnf:repetition-n 7 cIPv6-hex)))
    330 
    331 (define IPv6-comp    (abnf:concatenation
    332                       (abnf:optional-sequence (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 5 cIPv6-hex)))
    333                       (abnf:lit "::")
    334                       (abnf:optional-sequence (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 5 cIPv6-hex)))))
     352(define sub-domain     (consumed->string
     353                        (abnf:concatenation
     354                         Let-dig
     355                         (abnf:optional-sequence Ldh-str))))
     356
     357(define Domain         (consumed-strings->list
     358                        (abnf:concatenation
     359                         sub-domain
     360                         (abnf:repetition
     361                          (abnf:concatenation
     362                           (abnf:drop-consumed (abnf:char #\.))
     363                          sub-domain)))))
     364
     365(define At-domain    (abnf:concatenation
     366                      (abnf:drop-consumed (abnf:char #\@))
     367                      Domain))
     368
     369(define A-d-l        (abnf:concatenation
     370                      At-domain
     371                      (abnf:repetition
     372                       (abnf:concatenation
     373                        (abnf:drop-consumed (abnf:char #\,))
     374                        At-domain))))
     375
     376(define Local-part   (abnf:alternatives
     377                      Dot-string
     378                      Quoted-string))
     379
     380(define IPv6-hex     (consumed->string
     381                      (abnf:variable-repetition 1 4 abnf:hexadecimal)))
     382
     383(define cIPv6-hex    (abnf:concatenation
     384                      (abnf:drop-consumed (abnf:char #\:))
     385                      IPv6-hex))
     386
     387(define IPv6-full    (consumed-strings->list
     388                      (abnf:concatenation
     389                       IPv6-hex
     390                       (abnf:repetition-n 7 cIPv6-hex))))
     391
     392(define IPv6-comp    (consumed-strings->list
     393                      (abnf:concatenation
     394                       (abnf:optional-sequence
     395                        (abnf:concatenation
     396                         IPv6-hex
     397                         (abnf:variable-repetition 0 5 cIPv6-hex)))
     398                       (consumed->string (abnf:lit "::"))
     399                       (abnf:optional-sequence
     400                        (abnf:concatenation
     401                         IPv6-hex
     402                         (abnf:variable-repetition 0 5 cIPv6-hex))))))
    335403;; The "::" represents at least 2 16-bit groups of zeros.  No more
    336404;; than 6 groups in addition to the "::" may be present.
    337405
    338 (define Snum        (abnf:variable-repetition 1 3 abnf:decimal))
    339 
    340 (define IPv4-address-literal  (abnf:concatenation Snum (abnf:repetition-n 3 (abnf:concatenation (abnf:char #\.)  Snum))))
    341 
    342 (define IPv6v4-full   (abnf:concatenation IPv6-hex (abnf:repetition-n 5 cIPv6-hex)
    343                                           (abnf:char #\:) IPv4-address-literal))
    344 
    345 (define IPv6v4-comp   (abnf:concatenation (abnf:optional-sequence
    346                                            (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 3 cIPv6-hex)))
    347                                           (abnf:lit "::")
    348                                           (abnf:optional-sequence
    349                                            (abnf:concatenation IPv6-hex (abnf:variable-repetition 0 3 cIPv6-hex) ":"))
    350                                           IPv4-address-literal))
     406(define Snum        (consumed->string (abnf:variable-repetition 1 3 abnf:decimal)))
     407
     408(define IPv4-address-literal  (abnf:concatenation
     409                               Snum
     410                               (abnf:repetition-n
     411                                3 (abnf:concatenation
     412                                   (abnf:drop-consumed (abnf:char #\.)) 
     413                                   Snum))))
     414
     415(define IPv6v4-full   (consumed-strings->list
     416                       (abnf:concatenation
     417                        IPv6-hex (abnf:repetition-n 5 cIPv6-hex)
     418                        (abnf:drop-consumed (abnf:char #\:))
     419                        IPv4-address-literal)))
     420
     421(define IPv6v4-comp   (consumed-strings->list
     422                       (abnf:concatenation
     423                        (abnf:optional-sequence
     424                         (abnf:concatenation
     425                          IPv6-hex
     426                          (abnf:variable-repetition 0 3 cIPv6-hex)))
     427                        (consumed->string (abnf:lit "::"))
     428                        (abnf:optional-sequence
     429                         (abnf:concatenation
     430                          IPv6-hex
     431                          (abnf:variable-repetition 0 3 cIPv6-hex)
     432                         (abnf:drop-consumed (abnf:char #\:))))
     433                        IPv4-address-literal)))
    351434;; The "::" represents at least 2 16-bit groups of zeros.  No more
    352435;; than 4 groups in addition to the "::" and IPv4-address-literal may
    353436;; be present.
    354437
    355 (define IPv6-addr   (abnf:alternatives IPv6-full IPv6-comp IPv6v4-full IPv6v4-comp))
    356 
    357 
    358 (define IPv6-address-literal  (abnf:concatenation (abnf:lit "IPv6:") IPv6-addr))
    359 
    360 (define dcontent  (abnf:set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
    361 
    362 (define Standardized-tag  Ldh-str)
     438(define IPv6-addr   (abnf:alternatives IPv6-full IPv6-comp
     439                                       IPv6v4-full IPv6v4-comp))
     440
     441(define IPv6-address-literal  (abnf:concatenation
     442                               (consumed->string (abnf:lit "IPv6:")) IPv6-addr))
     443
     444(define dcontent  (abnf:set (char-set-difference
     445                             char-set:printing
     446                             (char-set #\[ #\] #\\))))
     447
     448(define Standardized-tag  (consumed->symbol Ldh-str))
    363449;; Standardized-tag MUST be specified in a Standards-Track RFC and
    364450;; registered with IANA
    365451
    366 (define General-address-literal  (abnf:concatenation Standardized-tag (abnf:char #\:) (abnf:repetition1 dcontent)))
     452(define General-address-literal  (abnf:concatenation
     453                                  Standardized-tag (abnf:drop-consumed (abnf:char #\:))
     454                                  (abnf:repetition1 dcontent)))
    367455
    368456(define address-literal  (abnf:concatenation
     
    376464
    377465(define Mailbox        (abnf:concatenation Local-part (abnf:char #\@) (abnf:alternatives Domain address-literal)))
    378 
    379 
    380466
    381467(define Path           (abnf:concatenation (abnf:char #\<)
Note: See TracChangeset for help on using the changeset viewer.