;;
;; Parser for the grammar defined in RFC 5322, "Internet Message Format".
;;
;; Based on the Haskell Rfc2822 module by Peter Simons.
;;
;; Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; .
(module internet-message
(CoreABNF->InetMessage )
(import scheme chicken data-structures srfi-1 srfi-14)
(require-extension typeclass)
(require-library srfi-1 srfi-13 abnf abnf-consumers)
(import (prefix abnf abnf:)
(prefix abnf-consumers abnf:)
(only abnf )
(only srfi-13 string-downcase)
)
(define-class ( A)
comment fields body message parts
text ftext quoted-string unstructured
addr-spec msg-id header
)
(define (char-list-titlecase x)
(if (null? x) x (cons (char-upcase (car x)) (map char-downcase (cdr x)))))
;; construct symbols from consumed chars
(define consumed-chars->tsymbol
(abnf:consumed-chars->list
(compose string->symbol
list->string
char-list-titlecase
abnf:trim-ws-char-list)))
;; shortcut for (abnf:bind consumed-chars->tsymbol (abnf:longest ... ))
(define-syntax bind-consumed->tsymbol
(syntax-rules ()
((_ p) (abnf:bind consumed-chars->tsymbol (abnf:longest p)))
))
(define consumed-objects-lift-any
(abnf:consumed-objects-lift
(abnf:consumed-objects identity)))
;; Construct a parser for a message header line from the header's name
;; and a parser for the body.
(define=> (header )
(lambda (s p)
(let ((ss (->string s)))
(lambda (#!key (crlf crlf) (alist #f))
(if alist
(let ((value (abnf:bind (consumed-objects-lift-any)
(abnf:concatenation
p
(abnf:drop-consumed crlf)))))
(lambda (kv)
(and (string=? (string-downcase ss) (string-downcase (car kv)))
(list ss (value (cdr kv))))))
(abnf:bind (consumed-objects-lift-any)
(abnf:concatenation
(bind-consumed->tsymbol (lit ss))
(abnf:drop-consumed (char #\:))
p
(abnf:drop-consumed crlf)
))
)))))
;; Primitive parsers (section 3.2.1)
;; Matches any US-ASCII character except for nul \r \n
(define=> (text )
(set (char-set-difference
char-set:ascii
(char-set (integer->char 0)
(integer->char 10)
(integer->char 13) ))))
;; Folding white space and comments (section 3.2.3)
(define=> (fws )
(abnf:concatenation
(abnf:optional-sequence
(abnf:concatenation
(abnf:repetition wsp)
(abnf:drop-consumed
(abnf:alternatives crlf lf cr))))
(abnf:repetition1 wsp)))
(define (between-fws-drop p fws)
(abnf:concatenation
(abnf:drop-consumed (abnf:optional-sequence fws)) p
(abnf:drop-consumed (abnf:optional-sequence fws))))
;; helper macro for mutually-recursive parser definitions
(define-syntax vac
(syntax-rules ()
((_ fn) (lambda args (apply fn args)))))
;; Quoted characters
(define=> (quoted-pair )
(abnf:concatenation
(abnf:drop-consumed (char #\\))
(abnf:alternatives vchar wsp)))
;; Matches any non-whitespace, non-control character except for ( ) and \
(define=> (ctext )
(set (char-set-difference char-set:graphic (char-set #\( #\) #\\))))
;; Matches comments. That is any combination of ctext, quoted pairs,
;; and fws between brackets. Comments may nest.
(define=> (ccontent )
(lambda (comment ctext quoted-pair)
(abnf:alternatives ctext quoted-pair comment)))
(define=> (comment )
(lambda (ccontent fws)
(abnf:concatenation
(char #\( )
(abnf:longest
(abnf:repetition
(abnf:concatenation
(abnf:optional-sequence fws)
ccontent
)))
(abnf:optional-sequence fws)
(char #\))
)))
;; Matches any combination of fws and comments
(define=> (cfws )
(lambda (comment fws)
(abnf:alternatives
(abnf:concatenation
(abnf:repetition1
(abnf:concatenation
(abnf:optional-sequence fws)
(abnf:drop-consumed comment)))
(abnf:optional-sequence fws))
fws)))
;; A combinator for sequences (optional cfws) p (optional cfws)
(define (between-cfws p cfws)
(abnf:concatenation
(abnf:optional-sequence cfws) p
(abnf:optional-sequence cfws) ))
(define (between-cfws-drop p cfws)
(abnf:concatenation
(abnf:drop-consumed (abnf:optional-sequence cfws)) p
(abnf:drop-consumed (abnf:optional-sequence cfws) )))
;; Atom (section 3.2.4)
;; Matches any US-ASCII character except for control characters,
;; specials, or space. atom and dot-atom are made up of this.
(define=> (atext )
(abnf:alternatives
alpha
decimal
(set-from-string "!#$%&'*+-/=?^_`{|}~")))
;; Matches one or more atext characters and skip any preceeding or
;; trailing cfws
(define=> (atom )
(lambda (atext cfws)
(abnf:bind-consumed->string
(between-cfws (abnf:repetition1 atext) cfws))))
;; Matches two or more atext elements interspersed by dots.
(define=> (dot-atom-text )
(lambda (atext)
(abnf:concatenation
(abnf:repetition1 atext)
(abnf:repetition
(abnf:concatenation
(char #\.)
(abnf:repetition1 atext)
)))))
;; Matches dot-atom-text and skips any preceeding or trailing cfws.
(define=> (dot-atom )
(lambda (dot-atom-text cfws)
(abnf:bind-consumed->string
(between-cfws dot-atom-text cfws))))
;; Quoted strings (section 3.2.4)
;;; Matches any non-whitespace, non-control US-ASCII character except
;;; for \ and "
(define char-set:quoted (char-set-difference char-set:printing (char-set #\\ #\")))
(define=> (qtext ) (set char-set:quoted))
;; Matches either qtext or quoted-pair
(define=> (qcontent )
(lambda (qtext quoted-pair)
(abnf:repetition1
(abnf:alternatives
qtext quoted-pair))))
;; Matches any number of qcontent between double quotes.
(define=> (quoted-string )
(lambda (qcontent fws cfws)
(abnf:bind-consumed->string
(between-cfws
(abnf:concatenation
(abnf:drop-consumed dquote)
(abnf:repetition
(abnf:concatenation
(abnf:optional-sequence fws)
qcontent))
(abnf:optional-sequence fws)
(abnf:drop-consumed dquote))
cfws)
)))
;; Miscellaneous tokens (section 3.2.5)
;;; Matches either atom or quoted-string
(define=> (word )
(lambda (atom quoted-string)
(abnf:alternatives atom quoted-string)))
;; Matches either one or more word elements
(define=> (phrase )
(lambda (word)
(abnf:bind-consumed-strings->list
(abnf:repetition1 word))))
;; Matches any number of utext tokens.
;;
;; Unstructured text is used in free text fields such as subject.
(define=> (unstructured )
(lambda (fws)
(abnf:bind-consumed->string
(abnf:concatenation
(abnf:repetition
(abnf:concatenation
(abnf:optional-sequence fws)
vchar))
(abnf:repetition wsp)))))
;; Date and Time Specification (section 3.3)
;; Parses a date and time specification of the form
;;
;; Thu, 19 Dec 2002 20:35:46 +0200
;;
;; where the weekday specification (Thu) is optional. The parser
;; This parser will not perform any consistency checking.
;; It will accept
;;
;; 40 Apr 2002 13:12 +0100
;;
;; as a perfectly valid date.
;; Matches the abbreviated weekday names
(define=> (day-name )
(abnf:alternatives
(lit "Mon")
(lit "Tue")
(lit "Wed")
(lit "Thu")
(lit "Fri")
(lit "Sat")
(lit "Sun")))
;; Matches a day-name, optionally wrapped in folding whitespace
(define=> (day-of-week )
(lambda (day-name fws)
(abnf:bind-consumed-strings->list
'day-of-week
(between-fws-drop
(abnf:bind-consumed->string day-name)
fws))))
;; Matches a four digit decimal number
(define=> (year )
(lambda (fws)
(between-fws-drop
(abnf:bind-consumed->string (abnf:repetition-n 4 decimal))
fws)))
;; Matches the abbreviated month names
(define=> (month-name )
(abnf:alternatives
(lit "Jan")
(lit "Feb")
(lit "Mar")
(lit "Apr")
(lit "May")
(lit "Jun")
(lit "Jul")
(lit "Aug")
(lit "Sep")
(lit "Oct")
(lit "Nov")
(lit "Dec")))
;; Matches a month-name, optionally wrapped in folding whitespace
(define=> (month )
(lambda (month-name fws)
(between-fws-drop (abnf:bind-consumed->string month-name)
fws)))
;; Matches a one or two digit number
(define=> (day )
(lambda (fws)
(abnf:concatenation
(abnf:drop-consumed (abnf:optional-sequence fws))
(abnf:alternatives
(abnf:bind-consumed->string (abnf:variable-repetition 1 2 decimal))
(abnf:drop-consumed fws)))))
;; Matches a date of the form dd:mm:yyyy
(define=> (date )
(lambda (day month year)
(abnf:bind-consumed-strings->list 'date
(abnf:concatenation day month year))))
;; Matches a two-digit number
(define=> (hour )
(abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (minute )
(abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (isecond )
(abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
;; Matches a time-of-day specification of hh:mm or hh:mm:ss.
(define=> (time-of-day )
(lambda (hour minute isecond)
(abnf:concatenation
hour (abnf:drop-consumed (char #\:))
minute (abnf:optional-sequence
(abnf:concatenation (abnf:drop-consumed (char #\:))
isecond)))))
;; Matches a timezone specification of the form
;; +hhmm or -hhmm
(define=> (zone )
(lambda (hour minute fws)
(abnf:concatenation
(abnf:drop-consumed fws)
(abnf:bind-consumed->string (abnf:alternatives (char #\-) (char #\+)))
hour minute)))
;; Matches a time-of-day specification followed by a zone.
(define=> (itime )
(lambda (time-of-day zone)
(abnf:bind-consumed-strings->list 'time
(abnf:concatenation time-of-day zone))))
(define=> (date-time )
(lambda (day-of-week date itime cfws)
(abnf:concatenation
(abnf:optional-sequence
(abnf:concatenation
day-of-week
(abnf:drop-consumed (char #\,))))
date
itime
(abnf:drop-consumed (abnf:optional-sequence cfws)))))
;; Address Specification (section 3.4)
;; Parses and returns a "local part" of an addr-spec. That is either
;; a dot-atom or a quoted-string.
(define=> (local-part )
(lambda (dot-atom quoted-string)
(abnf:alternatives dot-atom quoted-string)))
;; Parses and returns any ASCII characters except [ ] and \
(define=> (dtext )
(set (char-set-difference char-set:printing (char-set #\[ #\] #\\))))
;; Parses a domain literal. That is a [ character, followed by any
;; amount of dcontent, followed by a terminating ] character.
(define=> (domain-literal )
(lambda (dtext cfws )
(between-cfws
(abnf:concatenation
(abnf:drop-consumed (char #\[))
(abnf:bind-consumed->string
(abnf:repetition
(abnf:concatenation
(abnf:drop-consumed (abnf:optional-sequence fws))
dtext)))
(abnf:drop-consumed (abnf:optional-sequence fws))
(abnf:drop-consumed (char #\])))
cfws)))
;; Parses and returns a domain part of an addr-spec. That is either
;; a dot-atom or a domain-literal.
(define=> (domain )
(lambda (dot-atom domain-literal)
(abnf:alternatives dot-atom domain-literal)))
;; Addr-spec specification (section 3.4.1)
;; Parses an address specification. That is, a local-part, followed
;; by an \ character, followed by a domain.
(define=> (addr-spec )
(lambda (local-part domain)
(abnf:concatenation
(abnf:bind-consumed-strings->list 'local-part local-part)
(abnf:drop-consumed (char #\@))
(abnf:bind-consumed-strings->list 'domain domain))))
;; Parses an angle-addr
(define=> (angle-addr )
(lambda (addr-spec cfws)
(between-cfws-drop
(abnf:concatenation
(abnf:drop-consumed (char #\<))
addr-spec
(abnf:drop-consumed (char #\>))
)
cfws)))
;; Parses and returns a phrase.
(define=> (display-name )
(lambda (phrase)
(abnf:bind-consumed-pairs->list 'display-name phrase)))
;; Matches an angle-addr, optionally prefaced with a display-name
(define=> (name-addr )
(lambda (display-name angle-addr)
(abnf:concatenation
(abnf:optional-sequence display-name)
angle-addr)))
;; Matches a name-addr or an addr-spec and returns the address.
(define=> (mailbox )
(lambda (name-addr addr-spec)
(abnf:bind-consumed-pairs->list 'mailbox
(abnf:alternatives name-addr addr-spec))))
;; Parses a list of mailbox addresses, every two addresses being
;; separated by a comma, and returns the list of found address(es).
(define=> (mailbox-list )
(lambda (mailbox)
(abnf:bind-consumed-pairs->list 'mailbox-list
(abnf:concatenation
mailbox
(abnf:repetition
(abnf:concatenation
(abnf:drop-consumed (char #\,))
mailbox))))))
;; Parses a group of addresses. That is, a display-name, followed
;; by a colon, optionally followed by a mailbox-list, followed by a
;; semicolon. The found address(es) are returned - what may be none.
;; Here is an example:
;;
;; my group: user1@example.org, user2@example.org;
(define=> (group )
(lambda (display-name group-list cfws)
(abnf:bind-consumed-pairs->list 'group
(abnf:concatenation
display-name
(abnf:drop-consumed (char #\:))
(abnf:optional-sequence group-list)
(abnf:drop-consumed (char #\;))
(abnf:drop-consumed (abnf:optional-sequence cfws))))))
(define=> (group-list )
(lambda (mailbox-list cfws)
(abnf:alternatives
mailbox-list
(abnf:drop-consumed cfws))))
;; Matches a single mailbox or an address group
(define=> (address )
(lambda (mailbox group)
(abnf:alternatives mailbox group)))
;; Parses a list of address addresses, every two addresses being
;; separated by a comma, and returns the list of found address(es).
(define=> (address-list )
(lambda (address)
(abnf:concatenation
address
(abnf:repetition
(abnf:concatenation
(abnf:drop-consumed (char #\,))
address)))))
;; Overall message syntax (section 3.5)
;; This parser will return a message body as specified by the RFC;
;; that is basically any number of text characters, which may be
;; divided into separate lines by crlf.
(define=> (body )
(lambda (text)
(abnf:repetition
(abnf:concatenation
(abnf:repetition
(abnf:concatenation
(abnf:bind-consumed->string
(abnf:repetition text))
(abnf:drop-consumed
(abnf:repetition crlf))))
(abnf:bind-consumed->string
(abnf:repetition text))))))
;; Field definitions (section 3.6)
;; The origination date field (section 3.6.1)
;; Parses a Date: header and returns the date as a list
;; (year month dom hour min sec tz dow)
(define (orig-date header date-time) (header "Date" date-time))
;; Originator fields (section 3.6.2)
;; Parses a From: header and returns the mailbox-list address(es)
;; contained in it.
(define (from header mailbox-list) (header "From" mailbox-list))
;; Parses a Sender: header and returns the mailbox address contained in
;; it.
(define (sender header mailbox) (header "Sender" mailbox))
;; Parses a Reply-To: header and returns the address-list address(es)
;; contained in it.
(define (reply-to header address-list) (header "Reply-To" address-list))
;; Destination address fields (section 3.6.3)
;; Parses a To: header and returns the address-list address(es)
;; contained in it.
(define (to header address-list) (header "To" address-list))
;; Parses a Cc: header and returns the address-list address(es)
;; contained in it.
(define (cc header address-list) (header "Cc" address-list))
;; Parses a Bcc: header and returns the address-list address(es)
;; contained in it.
(define (bcc header address-list cfws)
(header "Bcc" (abnf:optional-sequence
(abnf:alternatives
address-list
(abnf:drop-consumed cfws)))))
;; Identification fields (section 3.6.4)
;; Parses one or more occurences of dtext or quoted-pair and returns the
;; concatenated string. This makes up the id-right of a msg-id.
(define=> (no-fold-literal )
(lambda (dtext)
(abnf:concatenation
(abnf:drop-consumed (char #\[))
(abnf:repetition dtext)
(abnf:drop-consumed (char #\])))))
;; Parses a left ID part of a msg-id. This is almost identical to
;; the local-part of an e-mail address, but with stricter rules
;; about folding and whitespace.
(define (id-left dot-atom-text) dot-atom-text )
;; Parses a right ID part of a msg-id. This is almost identical to the
;; domain of an e-mail address, but with stricter rules about folding
;; and whitespace.
(define (id-right dot-atom-text no-fold-literal)
(abnf:alternatives dot-atom-text no-fold-literal))
;; Parses a message ID and returns it. A message ID is almost identical
;; to an angle-addr, but with stricter rules about folding and
;; whitespace.
(define=> (msg-id )
(lambda (id-left id-right cfws)
(abnf:bind-consumed-strings->list 'message-id
(between-cfws-drop
(abnf:concatenation
(abnf:drop-consumed (char #\<))
(abnf:bind-consumed->string id-left)
(abnf:drop-consumed (char #\@))
(abnf:bind-consumed->string id-right)
(abnf:drop-consumed (char #\>))
)
cfws))))
;; Parses a In-Reply-To header and returns the list of msg-id's
;; contained in it.
(define (in-reply-to header msg-id) (header "In-Reply-To" (abnf:repetition1 msg-id)))
;; Parses a References: header and returns the list of msg-id's
;; contained in it.
(define (references header msg-id) (header "References" (abnf:repetition1 msg-id)))
;; Parses a Message-Id: header and returns the msg-id contained
;; in it.
(define (message-id header msg-id) (header "Message-ID" msg-id))
;; Informational fields (section 3.6.5)
;; Parses a Subject: header and returns its contents verbatim.
(define (subject header unstructured) (header "Subject" unstructured))
;; Parses a Comments: header and returns its contents verbatim.
(define (comments header unstructured) (header "Comments" unstructured))
;; Parses a Keywords: header and returns the list of phrases
;; found. Please note that each phrase is again a list of atoms, as
;; returned by the phrase parser.
(define=> (kwd-list )
(lambda (phrase)
(abnf:concatenation
phrase
(abnf:repetition
(abnf:concatenation
(abnf:drop-consumed (char #\,))
phrase)))))
(define (keywords header kwd-list) (header "Keywords" kwd-list))
;; Resent fields (section 3.6.6)
;; Parses a Resent-Date: header and returns the date it contains as
;; CalendarTime
(define (resent-date header date-time) (header "Resent-Date" date-time))
;; Parses a Resent-From: header and returns the mailbox-list address(es)
;; contained in it.
(define (resent-from header mailbox-list) (header "Resent-From" mailbox-list))
;; Parses a Resent-Sender: header and returns the mailbox-list
;; address(es) contained in it.
(define (resent-sender header mailbox) (header "Resent-Sender" mailbox))
;; Parses a Resent-To header and returns the mailbox address contained
;; in it.
(define (resent-to header address-list) (header "Resent-To" address-list))
;; Parses a Resent-Cc header and returns the address-list address(es)
;; contained in it.
(define (resent-cc header address-list) (header "Resent-Cc" address-list))
;; Parses a Resent-Bcc: header and returns the address-list
;; address(es) contained in it. (This list may be empty.)
(define (resent-bcc header address-list cfws)
(header "Resent-Bcc"
(abnf:alternatives
address-list
(abnf:drop-consumed
(abnf:optional-sequence cfws)))))
;; Parses a Resent-Message-ID: header and returns the msg-id contained
;; in it.
(define (resent-msg-id header msg-id)
(header "Resent-Message-ID" msg-id))
;; Parses a Resent-Reply-To: header and returns the address-list
;; contained in it.
(define (resent-reply-to header address-list)
(header "Resent-Reply-To" address-list))
;; Trace fields (section 3.6.7)
(define=> (path )
(lambda (angle-addr cfws)
(abnf:alternatives
angle-addr
(between-cfws-drop
(abnf:concatenation
(abnf:drop-consumed (char #\<))
(abnf:drop-consumed (abnf:optional-sequence cfws))
(abnf:drop-consumed (char #\>)))
cfws))))
(define (return-path header path) (header "Return-Path" path))
(define=> (received-token )
(lambda (domain angle-addr addr-spec word)
(abnf:bind-consumed-strings->list
'received-token
(abnf:alternatives domain angle-addr addr-spec word))))
(define=> (received-token-list )
(lambda (received-token date-time)
(abnf:concatenation
(abnf:repetition received-token)
(abnf:drop-consumed (char #\;))
date-time)))
(define (received header received-token-list)
(header "Received" received-token-list))
;; Optional fields (section 3.6.8)
;; Matches and returns any ASCII character except for control
;; characters, whitespace, and :
(define=> (ftext )
(set (char-set-difference char-set:graphic
(char-set #\:))))
;; Parses and returns an arbitrary header field name. That is one or
;; more ftext characters.
(define=> (field-name )
(lambda (ftext)
(bind-consumed->tsymbol (abnf:repetition1 ftext))))
;; Parses an arbitrary header field and returns a tuple containing the
;; field-name and unstructured text of the header. The name will not
;; contain the terminating colon.
(define=> (optional-field )
(lambda (field-name unstructured)
(lambda (#!key (crlf crlf) (alist #f))
(abnf:bind (consumed-objects-lift-any)
(abnf:concatenation
(if alist
abnf:pass
(abnf:concatenation
field-name
(abnf:drop-consumed (char #\:))))
unstructured
(abnf:drop-consumed crlf))))))
;; This parser will parse an arbitrary number of header fields as
;; defined in this RFC. For each field, an appropriate 'Field' value
;; is created, all of them making up the 'Field' list that this parser
;; returns.
;; Fields that contain syntax errors fall back to the catch-all
;; optional-field. Thus, this parser will hardly ever return a syntax
;; error -- what conforms with the idea that any message that can
;; possibly be accepted /should/ be.
(define=> (fields )
(lambda (from sender return-path reply-to to cc bcc message-id in-reply-to
references subject comments keywords orig-date resent-date
resent-from resent-sender resent-to resent-cc resent-bcc
resent-msg-id resent-reply-to received optional-field)
(lambda (#!key (crlf crlf))
(abnf:longest
(abnf:repetition
(abnf:alternatives
(from crlf: crlf)
(sender crlf: crlf)
(return-path crlf: crlf)
(reply-to crlf: crlf)
(to crlf: crlf)
(cc crlf: crlf)
(bcc crlf: crlf)
(message-id crlf: crlf)
(in-reply-to crlf: crlf)
(references crlf: crlf)
(subject crlf: crlf)
(comments crlf: crlf)
(keywords crlf: crlf)
(orig-date crlf: crlf)
(resent-date crlf: crlf)
(resent-from crlf: crlf)
(resent-sender crlf: crlf)
(resent-to crlf: crlf)
(resent-cc crlf: crlf)
(resent-bcc crlf: crlf)
(resent-msg-id crlf: crlf)
(resent-reply-to crlf: crlf)
(received crlf: crlf)
(optional-field crlf: crlf))))
)))
;; Parses a complete message as defined by the RFC and returns
;; the separate header fields and the message body.
(define=> (message )
(lambda (fields body)
(lambda (#!key (crlf crlf))
(abnf:bind-consumed-pairs->list
'message
(abnf:concatenation
(abnf:bind-consumed-pairs->list 'fields
(fields crlf: crlf))
(abnf:optional-sequence
(abnf:concatenation
(abnf:drop-consumed crlf)
(abnf:bind-consumed-strings->list 'body body)))
)))))
;; Given an alist of headers and a body, parses all header values and
;; the body, and returns a list of the form
;;
;; (PARSED-HEADERS PARSED-BODY)
;;
(define=> (parts )
(lambda (from sender return-path reply-to to cc bcc message-id in-reply-to
references subject comments keywords orig-date resent-date
resent-from resent-sender resent-to resent-cc resent-bcc
resent-msg-id resent-reply-to received optional-field)
(lambda (#!key (crlf crlf))
(let* (
(header-parsers
(map
(lambda (p) (p alist: #t crlf: crlf))
(list from
sender
return-path
reply-to
to
cc
bcc
message-id
in-reply-to
references
subject
comments
keywords
orig-date
resent-date
resent-from
resent-sender
resent-to
resent-cc
resent-bcc
resent-msg-id
resent-reply-to
received
optional-field)))
(try-header
(lambda (kv)
(let loop ((fs header-parsers))
(if (null? fs) kv
(let ((kv1 (apply (car fs) kv)))
(or kv1 (loop (cdr fs)))))))))
(lambda (unparsed-headers unparsed-body)
(let ((parsed-headers (map try-header unparsed-headers))
(parsed-body (body (unparsed-body))))
(list parsed-headers parsed-body)))))))
(define (CoreABNF->InetMessage A)
(letrec (
;; parsers for various header components
(*header (header A))
(*fws (fws A))
(*text (text A))
(*quoted-pair (quoted-pair A))
(*ctext (ctext A))
(*ccontent (vac ((ccontent A) *comment *ctext *quoted-pair)))
(*comment ((comment A) *ccontent *fws))
(*cfws ((cfws A) *comment *fws))
(*ftext (ftext A))
(*atext (atext A))
(*atom ((atom A) *atext *cfws))
(*dot-atom-text ((dot-atom-text A) *atext))
(*dot-atom ((dot-atom A) *dot-atom-text *cfws))
(*qtext (qtext A))
(*qcontent ((qcontent A) *qtext *quoted-pair))
(*quoted-string ((quoted-string A) *qcontent *fws *cfws))
(*word ((word A) *atom *quoted-string))
(*phrase ((phrase A) *word))
(*display-name ((display-name A) *phrase))
(*local-part ((local-part A) *dot-atom *quoted-string))
(*dtext (dtext A))
(*domain-literal ((domain-literal A) *dtext *cfws))
(*domain ((domain A) *dot-atom *domain-literal))
(*addr-spec ((addr-spec A) *local-part *domain))
(*angle-addr ((angle-addr A) *addr-spec *cfws))
(*name-addr ((name-addr A) *display-name *angle-addr))
(*mailbox ((mailbox A) *name-addr *addr-spec))
(*mailbox-list ((mailbox-list A) *mailbox))
(*group (vac ((group A) *display-name *group-list *cfws)))
(*group-list ((group-list A) *mailbox-list *cfws))
(*address ((address A) *mailbox *group))
(*address-list ((address-list A) *address))
(*path ((path A) *angle-addr *cfws))
(*no-fold-literal ((no-fold-literal A) *dtext))
(*id-left (id-left *dot-atom-text))
(*id-right (id-right *dot-atom-text *no-fold-literal))
(*msg-id ((msg-id A) *id-left *id-right *cfws))
(*unstructured ((unstructured A) *fws))
(*kwd-list ((kwd-list A) *phrase))
(*day-name (day-name A))
(*day-of-week ((day-of-week A) *day-name *fws))
(*year ((year A) *fws))
(*month-name (month-name A))
(*month ((month A) *month-name *fws))
(*day ((day A) *fws))
(*date ((date A) *day *month *year ))
(*hour (hour A))
(*minute (minute A))
(*isecond (isecond A))
(*time-of-day ((time-of-day A) *hour *minute *isecond))
(*zone ((zone A) *hour *minute *fws))
(*itime ((itime A) *time-of-day *zone))
(*date-time ((date-time A) *day-of-week *date *itime *cfws))
(*received-token ((received-token A) *domain *angle-addr *addr-spec *word))
(*received-token-list ((received-token-list A) *received-token *date-time))
(*field-name ((field-name A) *ftext))
(*optional-field ((optional-field A) *field-name *unstructured)))
(let* (
;; header parsers
(from (from *header *mailbox-list))
(sender (sender *header *mailbox))
(return-path (return-path *header *path))
(reply-to (reply-to *header *address-list))
(to (to *header *address-list))
(cc (cc *header *address-list))
(bcc (bcc *header *address-list *cfws))
(message-id (message-id *header *msg-id))
(in-reply-to (in-reply-to *header *msg-id))
(references (references *header *msg-id))
(subject (subject *header *unstructured))
(comments (comments *header *unstructured))
(keywords (keywords *header *kwd-list))
(orig-date (orig-date *header *date-time))
(received (received *header *received-token-list))
(resent-date (resent-date *header *date-time))
(resent-from (resent-from *header *mailbox-list))
(resent-sender (resent-sender *header *mailbox))
(resent-to (resent-to *header *address-list))
(resent-cc (resent-cc *header *address-list))
(resent-bcc (resent-bcc *header *address-list *cfws))
(resent-msg-id (resent-msg-id *header *msg-id))
(resent-reply-to (resent-reply-to *header *address-list))
;; parsers for various components of the message
(fields ((fields A)
from sender return-path reply-to to cc bcc
message-id in-reply-to references subject
comments keywords orig-date resent-date
resent-from resent-sender resent-to
resent-cc resent-bcc resent-msg-id
resent-reply-to received *optional-field))
(body ((body A) *text))
(message ((message A) fields body))
(parts ((parts A)
from sender return-path reply-to to cc bcc
message-id in-reply-to references subject
comments keywords orig-date resent-date
resent-from resent-sender resent-to
resent-cc resent-bcc resent-msg-id
resent-reply-to received *optional-field))
)
(make- A
*comment fields body message parts
*text *ftext *quoted-string *unstructured
*addr-spec *msg-id *header)
)))
)