Changeset 14967 in project


Ignore:
Timestamp:
06/11/09 05:33:45 (10 years ago)
Author:
Ivan Raikov
Message:

the beginning of a proper testsuite for internet-message

Location:
release/4/internet-message/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/internet-message/trunk/internet-message.scm

    r14964 r14967  
    123123    ))
    124124
    125 (define lcollect-pairs (lcollect pair?))
     125(define lcollect-pairs  (lcollect pair?))
    126126
    127127;; shortcut for (abnf:bind (lcollect-pairs ...) (abnf:longest ... ))
     
    133133
    134134
    135 
    136135;; Construct a parser for a message header line from the header's name
    137136;; and a parser for the body.
     
    139138(define (header s p) 
    140139  (let ((ss (->string s)))
    141     (abnf:concatenation
    142      (consumed->tsymbol (abnf:lit ss))
    143      (abnf:drop-consumed (abnf:char #\:))
    144      p
    145      (abnf:drop-consumed abnf:crlf)
    146      )))
     140    (abnf:bind ((lcollect identity))
     141     (abnf:concatenation
     142      (consumed->tsymbol (abnf:lit ss))
     143      (abnf:drop-consumed (abnf:char #\:))
     144      p
     145      (abnf:drop-consumed abnf:crlf)
     146      ))))
    147147
    148148
     
    169169   (abnf:repetition1 abnf:wsp)))
    170170
    171 (define (between-fws p)
     171(define (between-fws-drop p)
    172172  (abnf:concatenation
    173    (abnf:optional-sequence fws) p
    174    (abnf:optional-sequence fws)))
     173   (abnf:drop-consumed (abnf:optional-sequence fws)) p
     174   (abnf:drop-consumed (abnf:optional-sequence fws))))
    175175                             
    176176
     
    210210                (abnf:concatenation
    211211                 (abnf:optional-sequence fws)
    212                  comment))
     212                 (abnf:drop-consumed comment)))
    213213               (abnf:optional-sequence fws))
    214214              fws))
     
    219219(define (between-cfws p)
    220220  (abnf:concatenation
    221    (consumed->string (abnf:optional-sequence cfws)) p
    222    (consumed->string (abnf:optional-sequence cfws) )))
     221   (abnf:optional-sequence cfws) p
     222   (abnf:optional-sequence cfws) ))
     223                             
     224(define (between-cfws-drop p)
     225  (abnf:concatenation
     226   (abnf:drop-consumed (abnf:optional-sequence cfws)) p
     227   (abnf:drop-consumed (abnf:optional-sequence cfws) )))
    223228                             
    224229
     
    236241;; trailing cfws
    237242
    238 (define atom (between-cfws (consumed->string (abnf:repetition1 atext))))
     243(define atom (consumed->string (between-cfws (abnf:repetition1 atext))))
    239244
    240245;; Match two or more atext elements interspersed by dots.
     
    250255;; Match dot-atom-text and skip any preceeding or trailing cfws.
    251256
    252 (define dot-atom (between-cfws (consumed->string dot-atom-text)))
     257(define dot-atom (consumed->string (between-cfws dot-atom-text)))
    253258
    254259;; Quoted strings (section 3.2.4)
     
    263268;; Match either qtext or quoted-pair.
    264269
    265 (define qcontent (consumed->string
    266                   (abnf:repetition1
    267                    (abnf:alternatives
    268                     qtext abnf:quoted-pair))))
     270(define qcontent (abnf:repetition1
     271                  (abnf:alternatives
     272                   qtext abnf:quoted-pair)))
    269273
    270274;; Match any number of qcontent between double quotes.
    271275
    272276(define quoted-string
    273   (between-cfws
    274    (abnf:concatenation
    275     (abnf:drop-consumed abnf:dquote)
    276     (abnf:repetition
    277      (abnf:concatenation
    278       (abnf:optional-sequence fws)
    279       qcontent))
    280     (abnf:optional-sequence fws)
    281     (abnf:drop-consumed abnf:dquote))))
     277  (consumed->string
     278   (between-cfws
     279    (abnf:concatenation
     280     (abnf:drop-consumed abnf:dquote)
     281     (abnf:repetition
     282      (abnf:concatenation
     283       (abnf:optional-sequence fws)
     284       qcontent))
     285     (abnf:optional-sequence fws)
     286     (abnf:drop-consumed abnf:dquote)))))
    282287
    283288;; Miscellaneous tokens (section 3.2.5)
     
    289294;; Match either one or more word elements
    290295
    291 (define phrase (abnf:repetition1 word))
     296(define phrase (consumed-strings->list (abnf:repetition1 word)))
    292297
    293298
     
    334339;; Match a day-name, optionally wrapped in folding whitespace
    335340
    336 (define day-of-week (consumed-strings->list 'day-of-week (consumed->string (between-fws day-name))))
     341(define day-of-week (consumed-strings->list 'day-of-week (between-fws-drop (consumed->string day-name))))
    337342
    338343
    339344;; Match a four digit decimal number
    340345
    341 (define year (consumed->string (between-fws (abnf:repetition-n 4 abnf:decimal))))
     346(define year (between-fws-drop (consumed->string (abnf:repetition-n 4 abnf:decimal))))
    342347
    343348;; Match the abbreviated month names
     
    360365;; Match a month-name, optionally wrapped in folding whitespace
    361366
    362 (define month (consumed->string (between-fws month-name)))
     367(define month (between-fws-drop (consumed->string month-name)))
    363368
    364369
    365370;; Match a one or two digit number
    366371
    367 (define day (consumed->string
    368              (abnf:concatenation
    369               (abnf:drop-consumed (abnf:optional-sequence fws))
    370               (abnf:alternatives
    371                (abnf:repetition-n 2 abnf:decimal)
    372                (abnf:drop-consumed fws)))))
     372(define day (abnf:concatenation
     373             (abnf:drop-consumed (abnf:optional-sequence fws))
     374             (abnf:alternatives
     375              (consumed->string (abnf:repetition-n 2 abnf:decimal))
     376              (abnf:drop-consumed fws))))
    373377
    374378;; Match a date of the form dd:mm:yyyy
     
    377381;; Match a two-digit number
    378382
    379 (define hour     (consumed->string (abnf:repetition-n 2 abnf:decimal)))
    380 (define minute   (consumed->string (abnf:repetition-n 2 abnf:decimal)))
    381 (define second   (consumed->string (abnf:repetition-n 2 abnf:decimal)))
     383(define hour      (consumed->string (abnf:repetition-n 2 abnf:decimal)))
     384(define minute    (consumed->string (abnf:repetition-n 2 abnf:decimal)))
     385(define isecond   (consumed->string (abnf:repetition-n 2 abnf:decimal)))
    382386
    383387;; Match a time-of-day specification of hh:mm or hh:mm:ss.
     
    387391                     minute (abnf:optional-sequence
    388392                             (abnf:concatenation (abnf:drop-consumed (abnf:char #\:))
    389                                                  second))))
     393                                                 isecond))))
    390394
    391395;; Match a timezone specification of the form
     
    461465
    462466(define angle-addr
    463   (between-cfws
     467  (between-cfws-drop
    464468   (abnf:concatenation
    465469    (abnf:drop-consumed (abnf:char #\<))
     
    470474
    471475;; Parse and return a phrase.
    472 (define display-name (consumed-strings->list 'display-name phrase))
     476(define display-name  (consumed-pairs->list 'display-name phrase))
    473477
    474478;; Match an angle-addr, optionally prefaced with a display-name
     
    617621(define msg-id
    618622  (consumed-strings->list 'message-id
    619     (between-cfws (abnf:concatenation
    620                    (abnf:drop-consumed (abnf:char #\<))
    621                    (consumed->string id-left)
    622                    (abnf:drop-consumed (abnf:char #\@))
    623                    (consumed->string id-right)
    624                    (abnf:drop-consumed (abnf:char #\>))
    625                    ))))
     623    (between-cfws-drop
     624     (abnf:concatenation
     625      (abnf:drop-consumed (abnf:char #\<))
     626      (consumed->string id-left)
     627      (abnf:drop-consumed (abnf:char #\@))
     628      (consumed->string id-right)
     629      (abnf:drop-consumed (abnf:char #\>))
     630      ))))
    626631
    627632
     
    717722(define path    (abnf:alternatives
    718723                 angle-addr
    719                  (between-cfws 
     724                 (between-cfws-drop
    720725                 (abnf:concatenation
    721726                   (abnf:drop-consumed (abnf:char #\<))
     
    803808;;  the separate header fields and the message body.
    804809
    805 (define message (abnf:concatenation
    806                  (consumed-pairs->list 'fields fields)
    807                  (abnf:optional-sequence
    808                   (abnf:concatenation
    809                    (abnf:drop-consumed abnf:crlf)
    810                    (consumed-strings->list 'body body)))))
     810(define message
     811  (consumed-pairs->list
     812   'message
     813   (abnf:concatenation
     814    (consumed-pairs->list 'fields fields)
     815    (abnf:optional-sequence
     816     (abnf:concatenation
     817      (abnf:drop-consumed abnf:crlf)
     818      (consumed-strings->list 'body body))))))
    811819
    812820
  • release/4/internet-message/trunk/tests/run.scm

    r14961 r14967  
    1 (import srfi-14)
    2 (require-library internet-message abnf lexgen)
    3 (import internet-message)
     1
     2(use srfi-1 srfi-13 srfi-14)
     3
     4(require-library abnf lexgen)
    45(import (prefix abnf abnf:) (prefix lexgen lex:) )
     6(require-extension internet-message test)
    57
    68(define (string->input-stream s) `((() ,(string->list s))))
     
    1315(define (pr label) (lambda (s) (print label ": " s)))
    1416
    15 (comment (pr "comment") (string->input-stream "(a comment)"))
    1617
    17 ;; subject
    18 
    19 (fields (pr "subject") (string->input-stream "Subject: Test\r\n"))
    20 (fields (pr "subject") (string->input-stream "Subject:Test\r\n"))
    21 (fields (pr "subject") (string->input-stream "SUBJECT: Test\r\n"))
    22 (fields (pr "subject") (string->input-stream "SUBJECT: This is a\r\n test\r\n"))
    23 (fields (pr "subject") (string->input-stream "SUBJECT: This is a\r\n test\r\n"))
     18(define comment-cases
     19        `(
     20          ("(a comment)"  ((#\) #\t #\n #\e #\m #\m #\o #\c #\space #\a #\() ()))
     21          ))
    2422
    2523
    26 ;; keywords
    27 (fields (pr "keywords") (string->input-stream "Keywords: ErbB receptors\r\n"))
    28 (fields (pr "keywords") (string->input-stream "Keywords: ErbB receptors, EGF\r\n"))
    29 (fields (pr "keywords") (string->input-stream "Keywords: ErbB receptors, EGF, Signal transduction, Dimer, Subcellular\r\n localization, Fluorescent protein\r\n"))
     24(define  fields-cases
     25  `(
     26    ;; subject
     27    ("Subject: Test\r\n"   ((Subject " Test")))
     28    ("Subject:Test\r\n"    ((Subject "Test")))
     29    ("SUBJECT: Test\r\n"   ((Subject " Test")))
     30    ("SUBJECT: This is a\r\n test\r\n" ((Subject " This is a test")))
     31    ("SUBJECT: This is a\r\n test\r\n" ((Subject " This is a test")))
    3032
    31 ;; date
    32 (fields (pr "date") (string->input-stream "Date: Fri, 29 Aug 2008 12:21:46 +0200\r\n"))
     33    ;; keywords
     34    ("Keywords: ErbB receptors\r\n"       ((Keywords (" ErbB " "receptors"))))
     35    ("Keywords:  ErbB receptors, EGF\r\n"  ((Keywords ("  ErbB " "receptors") (" EGF"))))
     36    ("Keywords: ErbB receptors, EGF, Signal transduction, Dimer, Subcellular\r\n localization, Fluorescent protein\r\n"
     37     ((Keywords (" ErbB " "receptors") (" EGF") (" Signal " "transduction") (" Dimer")
     38                (" Subcellular " "localization") (" Fluorescent " "protein"))))
     39   
     40    ;; date
     41    ("Date: Fri, 29 Aug 2008 12:21:46 +0200\r\n" ((Date (day-of-week "Fri") (date "29" "Aug" "2008")
     42                                                        (time "12" "21" "46" "+" "02" "00"))))
     43   
     44    ;; different types of mailboxes
     45    ("From: John Doe <jdoe@machine.example>\r\n"
     46     ((From (mailbox-list (mailbox (display-name (" John "  "Doe ")) (local-part "jdoe") (domain "machine.example"))))))
     47    ("To: Mary Smith <mary@example.net>\r\n"     
     48     ((To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "example.net")))))
     49    ("From: \"Joe Q. Public\" <john.q.public@example.com>\r\n"   
     50     ((From (mailbox-list (mailbox (display-name (" Joe Q. Public ")) (local-part "john.q.public") (domain "example.com"))))))
     51    ("To: Mary Smith <mary@x.test>, jdoe@example.org\r\n"       
     52     ((To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "x.test"))
     53          (mailbox (local-part " jdoe") (domain "example.org")))))
     54    ("To:  Mary Smith <mary@x.test>, jdoe@example.org, Who? <one@y.test>\r\n"         
     55     ((To (mailbox (display-name ("  Mary " "Smith ")) (local-part "mary") (domain "x.test"))
     56          (mailbox (local-part " jdoe") (domain "example.org"))
     57          (mailbox (display-name (" Who? ")) (local-part "one") (domain "y.test")))))
     58    ("Cc: <boss@nil.test>, \"Giant; \\\"Big\\\" Box\" <sysservices@example.net>\r\n" 
     59     ((Cc (mailbox (local-part "boss") (domain "nil.test"))
     60          (mailbox (display-name (" Giant; \\\"Big\\\" Box ")) (local-part "sysservices") (domain "example.net")))))
     61    ("To: A Group:Ed Jones <c@a.test>,joe@where.test,John <jdoe@one.test>;\r\n" 
     62     ((To (group (display-name (" A " "Group"))
     63                 (mailbox-list (mailbox (display-name ("Ed " "Jones ")) (local-part "c") (domain "a.test"))
     64                               (mailbox (local-part "joe") (domain "where.test"))
     65                               (mailbox (display-name ("John ")) (local-part "jdoe") (domain "one.test")))))))
     66   
     67    ;; trace fields
     68    ("Message-ID: <1234@local.machine.example>\r\n"            ((Message-id (message-id "1234" "local.machine.example"))))
     69    ("Message-ID: <5678.21-Nov-1997@example.com>\r\n"          ((Message-id (message-id "5678.21-Nov-1997" "example.com"))))
     70    ("Message-ID: <testabcd.1234@silly.example>\r\n"           ((Message-id (message-id "testabcd.1234" "silly.example"))))
     71    ("References: <1234@local.machine.example> <3456@example.net>\r\n"
     72     ((References (message-id "1234" "local.machine.example") (message-id "3456" "example.net"))))
     73   
     74    ("Received: from node.example by x.y.test; 21 Nov 1997 10:01:22 -0600\r\n" 
     75     ((Received (received-token " from ") (received-token "node.example ") (received-token "by ")
     76                (received-token "x.y.test") (date "21" "Nov" "1997") (time "10" "01" "22" "-" "06" "00"))))
    3377
    34 ;; different types of mailboxes
     78    ("Received: from x.y.test\r\n    by example.net\r\n      via TCP\r\n      with ESMTP\r\n      id ABC12345\r\n       for <mary@example.net>;  21 Nov 1997 10:05:43 -0600\r\n"
     79     ((Received (received-token " from ") (received-token "x.y.test    ")
     80                (received-token "by ") (received-token "example.net      ")
     81                (received-token "via ") (received-token "TCP      ")
     82                (received-token "with ") (received-token "ESMTP      ")
     83                (received-token "id ") (received-token "ABC12345       ")
     84                (received-token "for ") (date "21" "Nov" "1997") (time "10" "05" "43" "-" "06" "00"))))
     85    ))
    3586
    36 (fields (pr "from")  (string->input-stream "From: John Doe <jdoe@machine.example>\r\n"))
    37 (fields (pr "to")    (string->input-stream "To: Mary Smith <mary@example.net>\r\n"))
    38 (fields (pr "from")  (string->input-stream "From: \"Joe Q. Public\" <john.q.public@example.com>\r\n"))
    39 (fields (pr "to")    (string->input-stream "To: Mary Smith <mary@x.test>, jdoe@example.org\r\n"))
    40 (fields (pr "to")    (string->input-stream "To:  Mary Smith <mary@x.test>, jdoe@example.org, Who? <one@y.test>\r\n"))
    41 (fields (pr "cc")    (string->input-stream "Cc: <boss@nil.test>, \"Giant; \\\"Big\\\" Box\" <sysservices@example.net>\r\n"))
     87(define message-cases
     88  `(
     89    ("From: John Doe <jdoe@machine.example>\r\nTo: Mary Smith <mary@example.net>\r\nSubject: Saying Hello\r\nDate: Fri, 21 Nov 1997 09:55:06 -0600\r\nMessage-ID: <1234@local.machine.example>\r\n\r\nThis is a message just to say hello.\r\nSo, \"Hello\"."
     90     ((message
     91       (fields (From (mailbox-list (mailbox (display-name (" John " "Doe ")) (local-part "jdoe") (domain "machine.example"))))
     92               (To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "example.net")))
     93               (Subject " Saying Hello")
     94               (Date (day-of-week "Fri") (date "21" "Nov" "1997") (time "09" "55" "06" "-" "06" "00"))
     95               (Message-id  (message-id "1234" "local.machine.example")))
     96       (body "This is a message just to say hello." "So, \"Hello\"."))))
     97    ))
    4298
    43 (fields (pr "to") (string->input-stream "To: A Group:Ed Jones <c@a.test>,joe@where.test,John <jdoe@one.test>;\r\n"));
     99(define (parse-fields cont s)
     100  (let ((cont1 (lambda (s) (cont (map caar s)))))
     101    (fields cont1 s)))
    44102
    45 (fields (pr "message-id") (string->input-stream "Message-ID: <1234@local.machine.example>\r\n"))
    46 (fields (pr "message-id") (string->input-stream "Message-ID: <5678.21-Nov-1997@example.com>\r\n"))
    47 (fields (pr "message-id") (string->input-stream "Message-ID: <testabcd.1234@silly.example>\r\n"))
    48 (fields (pr "references") (string->input-stream "References: <1234@local.machine.example> <3456@example.net>\r\n"))
     103(test-group "fields test"
     104  (for-each (lambda (p)
     105              (let ((inp (first p))
     106                    (res (second p)))
     107                (parse-fields (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) (string->input-stream inp))))
     108            fields-cases))
    49109
    50 (fields   (pr "received")  (string->input-stream "Received: from node.example by x.y.test; 21 Nov 1997 10:01:22 -0600\r\n"))
    51110
    52 (fields   (pr "received")  (string->input-stream "Received: from x.y.test\r\n    by example.net\r\n      via TCP\r\n      with ESMTP\r\n      id ABC12345\r\n       for <mary@example.net>;  21 Nov 1997 10:05:43 -0600\r\n"))
    53    
    54 (message (pr "message") (string->input-stream "From: John Doe <jdoe@machine.example>\r\nTo: Mary Smith <mary@example.net>\r\nSubject: Saying Hello\r\nDate: Fri, 21 Nov 1997 09:55:06 -0600\r\nMessage-ID: <1234@local.machine.example>\r\n\r\nThis is a message just to say hello.\r\nSo, \"Hello\"."))
     111(define (parse-message cont s)
     112  (let ((cont1 (lambda (s) (cont (map caar s)))))
     113    (message cont1 s)))
     114
     115(test-group "message test"
     116  (for-each (lambda (p)
     117              (let ((inp (first p))
     118                    (res (second p)))
     119                (parse-message (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) (string->input-stream inp))))
     120            message-cases))
     121
     122           
     123
     124
     125
     126
Note: See TracChangeset for help on using the changeset viewer.