source: project/release/4/internet-message/trunk/tests/run.scm @ 17239

Last change on this file since 17239 was 17239, checked in by Ivan Raikov, 12 years ago

introduced parametric end-of-line separator in internet-message

File size: 10.8 KB
Line 
1
2(use srfi-1 srfi-13 srfi-14)
3
4(require-library abnf lexgen)
5(import (prefix abnf abnf:) (prefix lexgen lex:) )
6(require-extension internet-message test)
7
8(define (string->input-stream s) `((() ,(string->list s)))) 
9
10(define (err s)
11  (print "lexical error on stream: " s)
12  (list))
13
14(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
15(define (pr label) (lambda (s) (print label ": " s)))
16
17
18(define (parse-fields cont s)
19  (let ((cont1 (lambda (s) (cont (map caar s)))))
20    ((fields) cont1 s)))
21
22
23(define (parse-message cont s)
24  (let ((cont1 (lambda (s) (cont (map caar s)))))
25    ((message) cont1 s)))
26
27
28(define comment-cases
29        `(
30          ("(a comment)"  ((#\) #\t #\n #\e #\m #\m #\o #\c #\space #\a #\() ()))
31          ))
32
33(define  fields-cases
34  `(
35    ;; subject
36    ("Subject: Test\r\n"   ((Subject " Test")))
37    ("Subject:Test\r\n"    ((Subject "Test")))
38    ("SUBJECT: Test\r\n"   ((Subject " Test")))
39    ("SUBJECT: This is a\r\n test\r\n" ((Subject " This is a test")))
40
41    ;; keywords
42    ("Keywords: ErbB receptors\r\n"       ((Keywords (" ErbB " "receptors"))))
43    ("Keywords:  ErbB receptors, EGF\r\n"  ((Keywords ("  ErbB " "receptors") (" EGF"))))
44    ("Keywords: ErbB receptors, EGF, Signal transduction, Dimer, Subcellular\r\n localization, Fluorescent protein\r\n"
45     ((Keywords (" ErbB " "receptors") (" EGF") (" Signal " "transduction") (" Dimer") 
46                (" Subcellular " "localization") (" Fluorescent " "protein"))))
47   
48    ;; date
49    ("Date: Fri, 29 Aug 2008 12:21:46 +0200\r\n" ((Date (day-of-week "Fri") (date "29" "Aug" "2008") 
50                                                        (time "12" "21" "46" "+" "02" "00"))))
51    ("Date: Fri,  2 Aug 2008 12:21:46 +0200\r\n" ((Date (day-of-week "Fri") (date "2" "Aug" "2008") 
52                                                        (time "12" "21" "46" "+" "02" "00"))))
53   
54    ;; different types of mailboxes
55    ("From: John Doe <jdoe@machine.example>\r\n" 
56     ((From (mailbox-list (mailbox (display-name (" John "  "Doe ")) (local-part "jdoe") (domain "machine.example"))))))
57    ("To: Mary Smith <mary@example.net>\r\n"     
58     ((To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "example.net")))))
59
60    ("From: \"Joe Q. Public\" <john.q.public@example.com>\r\n"   
61     ((From (mailbox-list (mailbox (display-name (" Joe Q. Public ")) (local-part "john.q.public") (domain "example.com"))))))
62    ("To: Mary Smith <mary@x.test>, jdoe@example.org\r\n"       
63     ((To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "x.test"))
64          (mailbox (local-part " jdoe") (domain "example.org")))))
65    ("To:  Mary Smith <mary@x.test>, jdoe@example.org, Who? <one@y.test>\r\n"         
66     ((To (mailbox (display-name ("  Mary " "Smith ")) (local-part "mary") (domain "x.test"))
67          (mailbox (local-part " jdoe") (domain "example.org"))
68          (mailbox (display-name (" Who? ")) (local-part "one") (domain "y.test")))))
69    ("Cc: <boss@nil.test>, \"Giant; \\\"Big\\\" Box\" <sysservices@example.net>\r\n" 
70     ((Cc (mailbox (local-part "boss") (domain "nil.test")) 
71          (mailbox (display-name (" Giant; \\\"Big\\\" Box ")) (local-part "sysservices") (domain "example.net")))))
72    ("To: A Group:Ed Jones <c@a.test>,joe@where.test,John <jdoe@one.test>;\r\n" 
73     ((To (group (display-name (" A " "Group")) 
74                 (mailbox-list (mailbox (display-name ("Ed " "Jones ")) (local-part "c") (domain "a.test")) 
75                               (mailbox (local-part "joe") (domain "where.test")) 
76                               (mailbox (display-name ("John ")) (local-part "jdoe") (domain "one.test")))))))
77   
78    ;; trace fields
79    ("Message-ID: <1234@local.machine.example>\r\n"            ((Message-id (message-id "1234" "local.machine.example"))))
80    ("Message-ID: <5678.21-Nov-1997@example.com>\r\n"          ((Message-id (message-id "5678.21-Nov-1997" "example.com"))))
81    ("Message-ID: <testabcd.1234@silly.example>\r\n"           ((Message-id (message-id "testabcd.1234" "silly.example"))))
82    ("References: <1234@local.machine.example> <3456@example.net>\r\n" 
83     ((References (message-id "1234" "local.machine.example") (message-id "3456" "example.net"))))
84    ("Received: from node.example by x.y.test; 21 Nov 1997 10:01:22 -0600\r\n" 
85     ((Received (received-token " from ") (received-token "node.example ") (received-token "by ") 
86                (received-token "x.y.test") (date "21" "Nov" "1997") (time "10" "01" "22" "-" "06" "00"))))
87
88    ("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"
89     ((Received (received-token " from ") (received-token "x.y.test    ") 
90                (received-token "by ") (received-token "example.net      ") 
91                (received-token "via ") (received-token "TCP      ") 
92                (received-token "with ") (received-token "ESMTP      ") 
93                (received-token "id ") (received-token "ABC12345       ") 
94                (received-token "for ") (local-part "mary") (domain "example.net")
95                (date "21" "Nov" "1997") (time "10" "05" "43" "-" "06" "00"))))
96    ;; optional fields
97    ("Content-Type: text/plain; charset=ISO-8859-1\r\n" 
98      ((Content-type " text/plain; charset=ISO-8859-1")))
99
100    ))
101
102(define message-cases
103  `(
104
105    ("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, \r\n\r\n\"Hello\"."
106     ((message 
107       (fields (From (mailbox-list (mailbox (display-name (" John " "Doe ")) (local-part "jdoe") (domain "machine.example"))))
108               (To (mailbox (display-name (" Mary " "Smith ")) (local-part "mary") (domain "example.net")))
109               (Subject " Saying Hello") 
110               (Date (day-of-week "Fri") (date "21" "Nov" "1997") (time "09" "55" "06" "-" "06" "00"))
111               (Message-id  (message-id "1234" "local.machine.example")))
112       (body "This is a message just to say hello." "So, " "\"Hello\"."))))
113
114    (,(string-concatenate
115       (list
116       "Return-Path: <chicken-users-bounces+ivan.g.raikov=gmail.com@nongnu.org>\r\n"
117       "Received: from lists.gnu.org (lists.gnu.org [199.232.76.165])\r\n   by mx.google.com with ESMTP id c14si3375477ana.41.2009.03.25.08.31.52;\r\n   Wed, 25 Mar 2009 08:31:53 -0700 (PDT)\r\n"
118       "Received: by fxm17 with SMTP id 17so92196fxm.34\r\n  for <chicken-users@nongnu.org>; Wed, 25 Mar 2009 08:31:25 -0700 (PDT)\r\n"
119       "DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma;\r\n h=domainkey-signature:mime-version:received:date:message-id:subject\r\n :from:to:content-type:content-transfer-encoding;\r\n    bh=3/gbdTTH19Zaqq1OYytiEg9lxqROJljdO4gXiBtCWl0=;\r\n    b=nFDjeva/nLcPlkXRsGTdHHkM15GSujBCy85V3vFXElSHEX2FRcGnkNc01N6xbJVpA8\r\n        s0hDM1gQwPvcuesuxJZ7UP79tbnBQqHAcOyMMQG2vcrhPjiGM2Zfx48cnfk7inydM5uL\r\n        aqKQLpqdQmoAfUoc7uqkCNwaD1wqRY86GbmFk=\r\n"
120       "MIME-Version: 1.0\r\n"
121       "Date: Wed, 25 Mar 2009 16:31:24 +0100\r\n"
122       "X-Gnus-Mail-Source: imap:imap.gmail.com:INBOX\r\n"
123       "Message-ID: <bd22bd7a0903250831k28553845he5099d4414f9b7d5@mail.gmail.com>\r\n"
124       "From: felix winkelmann <bunny351@gmail.com>\r\n"
125       "To: chicken chicken <chicken-users@nongnu.org>\r\n"
126       "Content-Type: text/plain; charset=ISO-8859-1\r\n"
127       "Content-Transfer-Encoding: 7bit\r\n"
128       "Subject: [Chicken-users] testing release candidate for 4.0.0\r\n"
129       "Sender: chicken-users-bounces+ivan.g.raikov=gmail.com@nongnu.org\r\n"
130       "Lines: 22\r\n"
131       "\r\n"
132       "Hi!\r\n"
133       "\r\n"
134       "\r\n"
135       "The current release candidate can be found at:\r\n"
136       "\r\n"
137       "http://www.call-with-current-continuation.org/chicken-4.0.0.tar.gz\r\n"
138       "\r\n"
139       "I tested it on several systems (mingw(+msys), linux), but would\r\n"
140       "appreciate if others could give it a try. Note that some minor\r\n"
141       "recent trunk changes didn't make it, due to unclear portability.\r\n"
142       "\r\n"
143       "cheers,\r\n"
144       "felix"))
145     ((message 
146       (fields
147        (Return-path (local-part "chicken-users-bounces+ivan.g.raikov=gmail.com") (domain "nongnu.org")) 
148        (Received (received-token " from ") (received-token "lists.gnu.org    ") (received-token "by ") 
149                  (received-token "mx.google.com ") (received-token "with ") (received-token "ESMTP ") 
150                  (received-token "id ") (received-token "c14si3375477ana.41.2009.03.25.08.31.52") 
151                  (day-of-week "Wed") (date "25" "Mar" "2009") (time "08" "31" "53" "-" "07" "00")) 
152        (Received (received-token " by ") (received-token "fxm17 ") (received-token "with ") 
153                  (received-token "SMTP ") (received-token "id ") (received-token "17so92196fxm.34  ") 
154                  (received-token "for ") (local-part "chicken-users") (domain "nongnu.org")
155                  (day-of-week "Wed") (date "25" "Mar" "2009") (time "08" "31" "25" "-" "07" "00"))
156        (Dkim-signature " v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma;\th=domainkey-signature:mime-version:received:date:message-id:subject\t:from:to:content-type:content-transfer-encoding;\tbh=3/gbdTTH19Zaqq1OYytiEg9lxqROJljdO4gXiBtCWl0=;\tb=nFDjeva/nLcPlkXRsGTdHHkM15GSujBCy85V3vFXElSHEX2FRcGnkNc01N6xbJVpA8\ts0hDM1gQwPvcuesuxJZ7UP79tbnBQqHAcOyMMQG2vcrhPjiGM2Zfx48cnfk7inydM5uL\taqKQLpqdQmoAfUoc7uqkCNwaD1wqRY86GbmFk=") 
157        (Mime-version " 1.0") 
158        (Date (day-of-week "Wed") (date "25" "Mar" "2009") (time "16" "31" "24" "+" "01" "00")) 
159        (X-gnus-mail-source " imap:imap.gmail.com:INBOX") 
160        (Message-id (message-id "bd22bd7a0903250831k28553845he5099d4414f9b7d5" "mail.gmail.com")) 
161        (From (mailbox-list (mailbox (display-name (" felix " "winkelmann ")) (local-part "bunny351") (domain "gmail.com")))) 
162        (To (mailbox (display-name (" chicken " "chicken ")) (local-part "chicken-users") (domain "nongnu.org"))) 
163        (Content-type " text/plain; charset=ISO-8859-1") 
164        (Content-transfer-encoding " 7bit") 
165        (Subject " [Chicken-users] testing release candidate for 4.0.0") 
166        (Sender (mailbox (local-part " chicken-users-bounces+ivan.g.raikov=gmail.com") (domain "nongnu.org"))) 
167        (Lines " 22")) 
168       (body "Hi!" "The current release candidate can be found at:" "http://www.call-with-current-continuation.org/chicken-4.0.0.tar.gz" "I tested it on several systems (mingw(+msys), linux), but would" "appreciate if others could give it a try. Note that some minor" "recent trunk changes didn't make it, due to unclear portability." "cheers," "felix"))))
169    ))
170
171
172(test-group "comments"
173  (for-each (lambda (p)
174              (let ((inp (first p))
175                    (res (second p)))
176                (comment (lambda (s) (test (apply sprintf "~S -> ~S" p) res  (car s))) (string->input-stream inp))))
177            comment-cases))
178
179(test-group "fields"
180  (for-each (lambda (p)
181              (let ((inp (first p))
182                    (res (second p)))
183                (parse-fields (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) (string->input-stream inp))))
184            fields-cases))
185
186(test-group "message"
187            (for-each (lambda (p)
188                        (let ((inp (first p))
189                              (res (second p)))
190                          (parse-message (lambda (s) (test (apply sprintf "~S -> ~S" p) res  s)) (string->input-stream inp))
191                          ))
192                      message-cases))
Note: See TracBrowser for help on using the repository browser.