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

Last change on this file since 18839 was 18839, checked in by Ivan Raikov, 11 years ago

converting internet-message to typeclass interface

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