source: project/release/4/internet-message/trunk/internet-message.scm @ 17939

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

internet-message: some more parsing combinators exported

File size: 22.5 KB
Line 
1;;
2;;  Parser for the grammar defined in RFC 5322, "Internet Message Format".
3;;
4;;  Based on the Haskell Rfc2822 module by Peter Simons.
5;;
6;;  Copyright 2009-2010 Ivan Raikov and the Okinawa Institute of
7;;  Science and Technology.
8;;
9;;
10;;  This program is free software: you can redistribute it and/or
11;;  modify it under the terms of the GNU General Public License as
12;;  published by the Free Software Foundation, either version 3 of the
13;;  License, or (at your option) any later version.
14;;
15;;  This program is distributed in the hope that it will be useful, but
16;;  WITHOUT ANY WARRANTY; without even the implied warranty of
17;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;;  General Public License for more details.
19;;
20;;  A full copy of the GPL license can be found at
21;;  <http://www.gnu.org/licenses/>.
22
23(module internet-message
24
25        (comment fields body message parts addr-spec text ftext msg-id)
26
27        (import scheme chicken data-structures srfi-1 srfi-14)
28
29        (require-library srfi-1 srfi-13 abnf abnf-consumers)
30        (import (prefix abnf abnf:) 
31                (prefix abnf-consumers abnf:) 
32                (only srfi-13 string-downcase)
33                )
34
35
36(define (char-list-titlecase x)
37  (if (null? x) x (cons (char-upcase (car x)) (map char-downcase (cdr x)))))
38
39;; construct symbols from consumed chars
40(define consumed-chars->tsymbol
41  (abnf:consumed-chars->list 
42   (compose string->symbol 
43            list->string 
44            char-list-titlecase 
45            abnf:trim-ws-char-list)))
46
47;; shortcut for (abnf:bind consumed-chars->tsymbol (abnf:longest ... ))
48(define-syntax bind-consumed->tsymbol
49  (syntax-rules () 
50    ((_ p)    (abnf:bind consumed-chars->tsymbol (abnf:longest p)))
51    ))
52
53(define consumed-objects-lift-any
54  (abnf:consumed-objects-lift
55   (abnf:consumed-objects identity)))
56
57;; Construct a parser for a message header line from the header's name
58;; and a parser for the body.
59
60(define (header s p) 
61  (let ((ss (->string s)))
62    (lambda (#!key (crlf abnf:crlf) (alist #f))
63        (if alist
64            (let ((value (abnf:bind (consumed-objects-lift-any)
65                                    (abnf:concatenation
66                                     p
67                                     (abnf:drop-consumed crlf)))))
68              (lambda (kv)
69                (and (string=? (string-downcase ss) (string-downcase (car kv)))
70                     (list ss (value (cdr kv))))))
71            (abnf:bind (consumed-objects-lift-any)
72                       (abnf:concatenation
73                        (bind-consumed->tsymbol (abnf:lit ss))
74                        (abnf:drop-consumed (abnf:char #\:))
75                        p
76                        (abnf:drop-consumed crlf)
77                        ))
78            ))))
79
80
81;; Primitive parsers (section 3.2.1)
82
83
84;; Matches any US-ASCII character except for nul \r \n
85
86(define text (abnf:set (char-set-difference
87                        char-set:ascii 
88                        (char-set (integer->char 0) 
89                                  (integer->char 10) 
90                                  (integer->char 13) ))))
91
92
93;; Folding white space and comments (section 3.2.3)
94
95(define fws
96  (abnf:concatenation
97   (abnf:optional-sequence 
98    (abnf:concatenation
99     (abnf:repetition abnf:wsp)
100     (abnf:drop-consumed 
101      (abnf:alternatives abnf:crlf abnf:lf abnf:cr))))
102   (abnf:repetition1 abnf:wsp)))
103
104(define (between-fws-drop p)
105  (abnf:concatenation
106   (abnf:drop-consumed (abnf:optional-sequence fws)) p 
107   (abnf:drop-consumed (abnf:optional-sequence fws))))
108                             
109
110;; helper macro for mutually-recursive parser definitions
111
112(define-syntax vac
113  (syntax-rules ()
114    ((_ fn) (lambda args (apply fn args)))))
115
116
117;; Matches any non-whitespace, non-control character except for ( ) and \
118
119(define ctext  (abnf:set (char-set-difference char-set:graphic (char-set #\( #\) #\\))))
120
121;; Matches comments. That is any combination of ctext, quoted pairs,
122;; and fws between brackets. Comments may nest.
123
124(define ccontent (vac (abnf:alternatives ctext abnf:quoted-pair comment)))
125
126(define comment (abnf:concatenation 
127                 (abnf:char #\( )
128                 (abnf:longest
129                  (abnf:repetition
130                   (abnf:concatenation
131                    (abnf:optional-sequence fws)
132                    ccontent
133                    )))
134                 (abnf:optional-sequence fws)
135                 (abnf:char #\))
136                 ))
137
138;; Matches any combination of fws and comments
139
140(define cfws (abnf:alternatives
141              (abnf:concatenation
142               (abnf:repetition1
143                (abnf:concatenation
144                 (abnf:optional-sequence fws)
145                 (abnf:drop-consumed comment)))
146               (abnf:optional-sequence fws))
147              fws))
148                 
149
150;;  A combinator for sequences (optional cfws) p (optional cfws)
151
152(define (between-cfws p)
153  (abnf:concatenation
154   (abnf:optional-sequence cfws) p 
155   (abnf:optional-sequence cfws) ))
156                             
157(define (between-cfws-drop p)
158  (abnf:concatenation
159   (abnf:drop-consumed (abnf:optional-sequence cfws)) p 
160   (abnf:drop-consumed (abnf:optional-sequence cfws) )))
161                             
162
163;; Atom (section 3.2.4)
164
165;; Matches any US-ASCII character except for control characters,
166;; specials, or space. atom and dot-atom are made up of this.
167
168(define atext (abnf:alternatives
169               abnf:alpha
170               abnf:decimal
171               (abnf:set-from-string "!#$%&'*+-/=?^_`{|}~")))
172
173;; Matches one or more atext characters and skip any preceeding or
174;; trailing cfws
175
176(define atom (abnf:bind-consumed->string (between-cfws (abnf:repetition1 atext))))
177
178;; Matches two or more atext elements interspersed by dots.
179
180(define dot-atom-text (abnf:concatenation
181                       (abnf:repetition1 atext)
182                       (abnf:repetition 
183                        (abnf:concatenation
184                         (abnf:char #\.)
185                         (abnf:repetition1 atext) 
186                         ))))
187
188;; Matches dot-atom-text and skips any preceeding or trailing cfws.
189
190(define dot-atom (abnf:bind-consumed->string (between-cfws dot-atom-text)))
191
192;; Quoted strings (section 3.2.4)
193
194;;; Matches any non-whitespace, non-control US-ASCII character except
195;;; for \ and "
196
197(define char-set:quoted (char-set-difference char-set:printing (char-set #\\ #\")))
198(define qtext (abnf:set char-set:quoted))
199
200
201;; Matches either qtext or quoted-pair
202
203(define qcontent (abnf:repetition1 
204                  (abnf:alternatives
205                   qtext abnf:quoted-pair)))
206
207;; Matches any number of qcontent between double quotes.
208
209(define quoted-string
210  (abnf:bind-consumed->string
211   (between-cfws 
212    (abnf:concatenation
213     (abnf:drop-consumed abnf:dquote)
214     (abnf:repetition
215      (abnf:concatenation
216       (abnf:optional-sequence fws)
217       qcontent))
218     (abnf:optional-sequence fws)
219     (abnf:drop-consumed abnf:dquote)))))
220
221;; Miscellaneous tokens (section 3.2.5)
222
223;;; Matches either atom or quoted-string
224
225(define word (abnf:alternatives atom quoted-string))
226
227;; Matches either one or more word elements
228
229(define phrase 
230  (abnf:bind-consumed-strings->list (abnf:repetition1 word)))
231
232
233;; Matches any number of utext tokens.
234;;
235;; Unstructured text is used in free text fields such as subject.
236
237(define unstructured 
238  (abnf:bind-consumed->string
239   (abnf:concatenation
240    (abnf:repetition 
241     (abnf:concatenation
242      (abnf:optional-sequence fws)
243      abnf:vchar))
244    (abnf:repetition abnf:wsp))))
245
246;; Date and Time Specification (section 3.3)
247
248;; Parses a date and time specification of the form
249;;
250;;   Thu, 19 Dec 2002 20:35:46 +0200
251;;
252;; where the weekday specification (Thu) is optional. The parser
253;; This parser will not perform any consistency checking.
254;; It will accept
255;;
256;;    40 Apr 2002 13:12 +0100
257;;
258;;  as a perfectly valid date.
259
260                             
261;; Matches the abbreviated weekday names
262
263(define day-name 
264  (abnf:alternatives
265   (abnf:lit "Mon")
266   (abnf:lit "Tue")
267   (abnf:lit "Wed")
268   (abnf:lit "Thu")
269   (abnf:lit "Fri")
270   (abnf:lit "Sat")
271   (abnf:lit "Sun")))
272
273;; Matches a day-name, optionally wrapped in folding whitespace
274
275(define day-of-week 
276  (abnf:bind-consumed-strings->list 
277   'day-of-week 
278   (between-fws-drop 
279    (abnf:bind-consumed->string day-name))))
280
281
282;; Matches a four digit decimal number
283
284(define year 
285  (between-fws-drop
286   (abnf:bind-consumed->string (abnf:repetition-n 4 abnf:decimal))))
287
288;; Matches the abbreviated month names
289
290
291(define month-name (abnf:alternatives
292                    (abnf:lit "Jan")
293                    (abnf:lit "Feb")
294                    (abnf:lit "Mar")
295                    (abnf:lit "Apr")
296                    (abnf:lit "May")
297                    (abnf:lit "Jun")
298                    (abnf:lit "Jul")
299                    (abnf:lit "Aug")
300                    (abnf:lit "Sep")
301                    (abnf:lit "Oct")
302                    (abnf:lit "Nov")
303                    (abnf:lit "Dec")))
304
305;; Matches a month-name, optionally wrapped in folding whitespace
306
307(define month (between-fws-drop (abnf:bind-consumed->string month-name)))
308
309
310;; Matches a one or two digit number
311
312(define day (abnf:concatenation
313             (abnf:drop-consumed (abnf:optional-sequence fws))
314             (abnf:alternatives 
315              (abnf:bind-consumed->string (abnf:variable-repetition 1 2 abnf:decimal))
316              (abnf:drop-consumed fws))))
317
318;; Matches a date of the form dd:mm:yyyy
319(define date 
320  (abnf:bind-consumed-strings->list 'date 
321    (abnf:concatenation day month year)))
322
323;; Matches a two-digit number
324
325(define hour      (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
326(define minute    (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
327(define isecond   (abnf:bind-consumed->string (abnf:repetition-n 2 abnf:decimal)))
328
329;; Matches a time-of-day specification of hh:mm or hh:mm:ss.
330
331(define time-of-day (abnf:concatenation
332                     hour (abnf:drop-consumed (abnf:char #\:))
333                     minute (abnf:optional-sequence 
334                             (abnf:concatenation (abnf:drop-consumed (abnf:char #\:))
335                                                 isecond))))
336
337;; Matches a timezone specification of the form
338;; +hhmm or -hhmm
339
340(define zone (abnf:concatenation 
341              (abnf:drop-consumed fws)
342              (abnf:bind-consumed->string (abnf:alternatives (abnf:char #\-) (abnf:char #\+)))
343              hour minute))
344
345;; Matches a time-of-day specification followed by a zone.
346
347(define itime 
348  (abnf:bind-consumed-strings->list 'time 
349    (abnf:concatenation time-of-day zone)))
350
351(define date-time (abnf:concatenation
352                   (abnf:optional-sequence
353                    (abnf:concatenation
354                     day-of-week
355                     (abnf:drop-consumed (abnf:char #\,))))
356                   date
357                   itime
358                   (abnf:drop-consumed (abnf:optional-sequence cfws))))
359
360
361;; Address Specification (section 3.4)
362
363
364;; Parses and returns a "local part" of an addr-spec. That is either
365;; a dot-atom or a quoted-string.
366
367(define local-part (abnf:alternatives dot-atom quoted-string))
368
369
370;; Parses and returns any ASCII characters except [ ] and \
371
372(define dtext  (abnf:set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
373
374
375;; Parses a domain literal. That is a [ character, followed by any
376;; amount of dcontent, followed by a terminating ] character.
377
378(define domain-literal (between-cfws
379                         (abnf:concatenation
380                          (abnf:drop-consumed (abnf:char #\[))
381                          (abnf:bind-consumed->string 
382                           (abnf:repetition 
383                            (abnf:concatenation
384                             (abnf:drop-consumed (abnf:optional-sequence fws))
385                             dtext)))
386                          (abnf:drop-consumed (abnf:optional-sequence fws))
387                          (abnf:drop-consumed (abnf:char #\]))
388                          )))
389
390;; Parses and returns a domain part of an addr-spec. That is either
391;; a dot-atom or a domain-literal.
392
393(define domain  (abnf:alternatives dot-atom domain-literal))
394
395
396;; Addr-spec specification (section 3.4.1)
397
398;; Parses an address specification. That is, a local-part, followed
399;; by an \ character, followed by a domain.
400
401(define addr-spec
402  (abnf:concatenation
403   (abnf:bind-consumed-strings->list 'local-part local-part)
404   (abnf:drop-consumed (abnf:char #\@))
405   (abnf:bind-consumed-strings->list 'domain domain)))
406
407;; Parses an angle-addr
408
409(define angle-addr
410  (between-cfws-drop
411   (abnf:concatenation
412    (abnf:drop-consumed (abnf:char #\<))
413    addr-spec
414    (abnf:drop-consumed (abnf:char #\>))
415    )))
416
417
418;; Parses and returns a phrase.
419(define display-name  (abnf:bind-consumed-pairs->list 'display-name phrase))
420
421;; Matches an angle-addr, optionally prefaced with a display-name
422
423(define name-addr
424  (abnf:concatenation
425   (abnf:optional-sequence display-name)
426   angle-addr))
427
428;; Matches a name-addr or an addr-spec and returns the address.
429
430(define mailbox 
431  (abnf:bind-consumed-pairs->list 'mailbox 
432   (abnf:alternatives name-addr addr-spec)))
433
434;; Parses a list of mailbox addresses, every two addresses being
435;; separated by a comma, and returns the list of found address(es).
436
437(define mailbox-list
438  (abnf:bind-consumed-pairs->list 'mailbox-list
439   (abnf:concatenation
440    mailbox
441    (abnf:repetition
442     (abnf:concatenation
443      (abnf:drop-consumed (abnf:char #\,))
444      mailbox)))))
445
446
447;; Parses a group of addresses. That is, a display-name, followed
448;; by a colon, optionally followed by a mailbox-list, followed by a
449;; semicolon. The found address(es) are returned - what may be none.
450;; Here is an example:
451;;
452;;    my group: user1@example.org, user2@example.org;
453
454(define group (vac (abnf:bind-consumed-pairs->list 'group 
455                   (abnf:concatenation
456                    display-name
457                    (abnf:drop-consumed (abnf:char #\:))
458                    (abnf:optional-sequence group-list)
459                    (abnf:drop-consumed (abnf:char #\;))
460                    (abnf:drop-consumed (abnf:optional-sequence cfws))))))
461 
462(define group-list (abnf:alternatives 
463                    mailbox-list
464                    (abnf:drop-consumed cfws)))
465
466;; Matches a single mailbox or an address group
467
468(define address (abnf:alternatives mailbox group))
469
470;; Parses a list of address addresses, every two addresses being
471;; separated by a comma, and returns the list of found address(es).
472
473(define address-list (abnf:concatenation
474                      address
475                      (abnf:repetition
476                       (abnf:concatenation
477                        (abnf:drop-consumed (abnf:char #\,))
478                        address))))
479
480;;  Overall message syntax (section 3.5)
481                             
482;; This parser will return a message body as specified by the RFC;
483;; that is basically any number of text characters, which may be
484;; divided into separate lines by crlf.
485
486(define body (abnf:repetition
487              (abnf:concatenation
488               (abnf:repetition 
489                 (abnf:concatenation
490                  (abnf:bind-consumed->string
491                   (abnf:repetition text))
492                  (abnf:drop-consumed 
493                   (abnf:repetition abnf:crlf))))
494               (abnf:bind-consumed->string
495                (abnf:repetition text)))))
496
497;; Field definitions (section 3.6)
498
499;; The origination date field (section 3.6.1)
500
501;; Parses a Date: header and returns the date as a list
502;; (year month dom hour min sec tz dow)
503
504(define orig-date  (header "Date" date-time))
505
506;; Originator fields (section 3.6.2)
507
508;; Parses a From: header and returns the mailbox-list address(es)
509;; contained in it.
510
511(define from      (header "From" mailbox-list))
512
513;; Parses a Sender: header and returns the mailbox address contained in
514;; it.
515
516(define sender    (header "Sender" mailbox))
517
518;; Parses a Reply-To: header and returns the address-list address(es)
519;; contained in it.
520
521(define reply-to  (header "Reply-To" address-list))
522
523;; Destination address fields (section 3.6.3)
524
525;; Parses a To: header and returns the address-list address(es)
526;; contained in it.
527
528(define to        (header "To" address-list))
529
530;; Parses a Cc: header and returns the address-list address(es)
531;; contained in it.
532
533(define cc        (header "Cc" address-list))
534
535;; Parses a Bcc: header and returns the address-list address(es)
536;; contained in it.
537
538(define bcc       (header "Bcc" (abnf:optional-sequence 
539                                 (abnf:alternatives
540                                  address-list
541                                  (abnf:drop-consumed cfws)))))
542
543;; Identification fields (section 3.6.4)
544
545;; Parses one or more occurences of dtext or quoted-pair and returns the
546;; concatenated string. This makes up the id-right of a msg-id.
547
548(define no-fold-literal  (abnf:concatenation
549                          (abnf:drop-consumed (abnf:char #\[))
550                          (abnf:repetition dtext)
551                          (abnf:drop-consumed (abnf:char #\]))))
552
553;; Parses a left ID part of a msg-id. This is almost identical to
554;; the local-part of an e-mail address, but with stricter rules
555;; about folding and whitespace.
556
557(define id-left   dot-atom-text )
558
559;; Parses a right ID part of a msg-id. This is almost identical to the
560;; domain of an e-mail address, but with stricter rules about folding
561;; and whitespace.
562
563(define id-right  (abnf:alternatives dot-atom-text no-fold-literal))
564
565;; Parses a message ID and returns it. A message ID is almost identical
566;; to an angle-addr, but with stricter rules about folding and
567;; whitespace.
568
569(define msg-id
570  (abnf:bind-consumed-strings->list 'message-id
571    (between-cfws-drop
572     (abnf:concatenation
573      (abnf:drop-consumed (abnf:char #\<))
574      (abnf:bind-consumed->string id-left)
575      (abnf:drop-consumed (abnf:char #\@))
576      (abnf:bind-consumed->string id-right)
577      (abnf:drop-consumed (abnf:char #\>))
578      ))))
579
580
581;; Parses a In-Reply-To header and returns the list of msg-id's
582;; contained in it.
583
584(define in-reply-to (header "In-Reply-To" (abnf:repetition1 msg-id)))
585
586;; Parses a References: header and returns the list of msg-id's
587;; contained in it.
588
589(define references  (header "References"  (abnf:repetition1 msg-id)))
590
591;; Parses a Message-Id: header and returns the msg-id contained
592;; in it.
593
594(define message-id (header "Message-ID" msg-id))
595                                           
596;; Informational fields (section 3.6.5)
597
598;; Parses a Subject: header and returns its contents verbatim.
599
600(define subject (header "Subject"  unstructured))
601
602;; Parses a Comments: header and returns its contents verbatim.
603
604(define comments (header "Comments" unstructured))
605
606;; Parses a Keywords: header and returns the list of phrases
607;; found. Please note that each phrase is again a list of atoms, as
608;; returned by the phrase parser.
609
610(define keywords  (header "Keywords"
611                           (abnf:concatenation
612                            phrase
613                            (abnf:repetition
614                             (abnf:concatenation
615                              (abnf:drop-consumed (abnf:char #\,))
616                              phrase)))))
617
618;; Resent fields (section 3.6.6)
619
620;; Parses a Resent-Date: header and returns the date it contains as
621;; CalendarTime
622
623(define resent-date (header "Resent-Date" date-time))
624
625;; Parses a Resent-From: header and returns the mailbox-list address(es)
626;; contained in it.
627
628(define resent-from  (header "Resent-From" mailbox-list))
629
630;; Parses a Resent-Sender: header and returns the mailbox-list
631;; address(es) contained in it.
632
633(define resent-sender (header "Resent-Sender" mailbox))
634
635;; Parses a Resent-To header and returns the mailbox address contained
636;; in it.
637
638(define resent-to  (header "Resent-To" address-list))
639
640;; Parses a Resent-Cc header and returns the address-list address(es)
641;; contained in it.
642
643(define resent-cc (header "Resent-Cc" address-list))
644
645;; Parses a Resent-Bcc: header and returns the address-list
646;; address(es) contained in it. (This list may be empty.)
647
648(define resent-bcc   (header "Resent-Bcc"
649                             (abnf:alternatives 
650                              address-list
651                              (abnf:drop-consumed (abnf:optional-sequence cfws)))))
652
653
654;; Parses a Resent-Message-ID: header and returns the msg-id contained
655;; in it.
656
657(define resent-msg-id  (header "Resent-Message-ID" msg-id))
658
659
660;; Parses a Resent-Reply-To: header and returns the address-list
661;; contained in it.
662
663(define resent-reply-to  (header "Resent-Reply-To" address-list))
664
665
666;; Trace fields (section 3.6.7)
667
668                         
669(define path    (abnf:alternatives 
670                 angle-addr
671                 (between-cfws-drop
672                 (abnf:concatenation
673                   (abnf:drop-consumed (abnf:char #\<))
674                   (abnf:drop-consumed (abnf:optional-sequence cfws))
675                   (abnf:drop-consumed (abnf:char #\>))))))
676
677(define return-path  (header "Return-Path" path))
678
679(define received-token 
680  (abnf:bind-consumed-strings->list
681   'received-token
682   (abnf:alternatives domain angle-addr addr-spec word)))
683
684(define received  (header "Received" 
685                           (abnf:concatenation
686                            (abnf:repetition received-token)
687                            (abnf:drop-consumed (abnf:char #\;))
688                            date-time)))
689
690
691;; Optional fields (section 3.6.8)
692
693;; Matches and returns any ASCII character except for control
694;; characters, whitespace, and :
695
696(define ftext  (abnf:set (char-set-difference char-set:graphic
697                                              (char-set #\:))))
698
699
700;; Parses and returns an arbitrary header field name. That is one or
701;; more ftext characters.
702
703(define field-name (bind-consumed->tsymbol (abnf:repetition1 ftext)))
704
705;; Parses an arbitrary header field and returns a tuple containing the
706;; field-name and unstructured text of the header. The name will not
707;; contain the terminating colon.
708
709(define optional-field 
710  (lambda (#!key (crlf abnf:crlf) (alist #f))
711    (abnf:bind (consumed-objects-lift-any)
712               (abnf:concatenation
713                (if alist
714                    abnf:pass
715                    (abnf:concatenation
716                     field-name
717                     (abnf:drop-consumed (abnf:char #\:))))
718                unstructured
719                (abnf:drop-consumed crlf)))))
720 
721;; This parser will parse an arbitrary number of header fields as
722;; defined in this RFC. For each field, an appropriate 'Field' value
723;; is created, all of them making up the 'Field' list that this parser
724;; returns.
725
726;; Fields that contain syntax errors fall back to the catch-all
727;; optional-field. Thus, this parser will hardly ever return a syntax
728;; error -- what conforms with the idea that any message that can
729;; possibly be accepted /should/ be.
730
731(define fields
732  (lambda (#!key (crlf abnf:crlf))
733    (abnf:longest
734     (abnf:repetition
735      (abnf:alternatives
736       (from           crlf: crlf)
737       (sender         crlf: crlf)
738       (return-path    crlf: crlf)
739       (reply-to       crlf: crlf)
740       (to             crlf: crlf)
741       (cc             crlf: crlf)
742       (bcc            crlf: crlf)
743       (message-id     crlf: crlf)
744       (in-reply-to    crlf: crlf)
745       (references     crlf: crlf)
746       (subject        crlf: crlf)
747       (comments       crlf: crlf)
748       (keywords       crlf: crlf)
749       (orig-date      crlf: crlf)
750       (resent-date    crlf: crlf)
751       (resent-from    crlf: crlf)
752       (resent-sender  crlf: crlf)
753       (resent-to      crlf: crlf)
754       (resent-cc      crlf: crlf)
755       (resent-bcc     crlf: crlf)
756       (resent-msg-id    crlf: crlf)
757       (resent-reply-to  crlf: crlf)
758       (received         crlf: crlf)
759       (optional-field   crlf: crlf))))
760    ))
761
762
763;; Parses a complete message as defined by the RFC and returns
764;; the separate header fields and the message body.
765
766(define message
767  (lambda (#!key (crlf abnf:crlf))
768    (abnf:bind-consumed-pairs->list 
769     'message
770     (abnf:concatenation 
771      (abnf:bind-consumed-pairs->list 'fields 
772       (fields crlf: crlf))
773      (abnf:optional-sequence
774       (abnf:concatenation 
775        (abnf:drop-consumed crlf)
776        (abnf:bind-consumed-strings->list 'body body)))
777      ))))
778
779;; Given an alist of headers and a body, parses all header values and
780;; the body, and returns a list of the form
781;;
782;; (PARSED-HEADERS PARSED-BODY)
783;;
784
785(define parts
786  (lambda (#!key (crlf abnf:crlf))
787    (let* ((header-parsers
788           (map
789            (lambda (p) (p alist: #t crlf: crlf))
790            (list from
791                  sender
792                  return-path
793                  reply-to
794                  to
795                  cc
796                  bcc
797                  message-id
798                  in-reply-to
799                  references
800                  subject
801                  comments
802                  keywords
803                  orig-date
804                  resent-date
805                  resent-from
806                  resent-sender
807                  resent-to
808                  resent-cc
809                  resent-bcc
810                  resent-msg-id
811                  resent-reply-to
812                  received
813                  optional-field)))
814           (try-header
815            (lambda (kv)
816              (let loop ((fs header-parsers))
817                (if (null? fs) kv
818                    (let ((kv1 (apply (car fs) kv)))
819                      (or kv1 (loop (cdr fs)))))))))
820      (lambda (unparsed-headers unparsed-body)
821        (let ((parsed-headers (map try-header unparsed-headers))
822              (parsed-body (body (unparsed-body))))
823          (list parsed-headers parsed-body))))))
824   
825)
Note: See TracBrowser for help on using the repository browser.