;;
;;  Parser for the grammar defined in RFC 5322, "Internet Message Format".
;;
;;  Based on the Haskell Rfc2822 module by Peter Simons.
;;
;;  Copyright 2009-2010 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
;;  <http://www.gnu.org/licenses/>.

(module internet-message

	(CoreABNF->InetMessage <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 <CoreABNF> <Input> <Token> <CharLex> )
		(only srfi-13 string-downcase)
		)



(define-class <InetMessage> (<CoreABNF> A)  
  comment fields body message parts 
  text ftext quoted-string unstructured
  addr-spec msg-id 
  )

(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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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)))))


;; Matches any non-whitespace, non-control character except for ( ) and \

(define=> (ctext <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (comment ctext)
    (abnf:alternatives ctext quoted-pair comment)))

(define=> (comment <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (abnf:alternatives
   alpha
   decimal
   (set-from-string "!#$%&'*+-/=?^_`{|}~")))

;; Matches one or more atext characters and skip any preceeding or
;; trailing cfws

(define=> (atom <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>) (set char-set:quoted))


;; Matches either qtext or quoted-pair

(define=> (qcontent  <CoreABNF>)
  (lambda (qtext)
    (abnf:repetition1 
     (abnf:alternatives
      qtext quoted-pair))))

;; Matches any number of qcontent between double quotes.

(define=> (quoted-string <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (atom quoted-string)
    (abnf:alternatives atom quoted-string)))
  
;; Matches either one or more word elements 

(define=> (phrase  <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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  <CoreABNF>)
  (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  <CoreABNF>)
  (lambda (fws)
    (between-fws-drop
     (abnf:bind-consumed->string (abnf:repetition-n 4 decimal))
     fws)))

;; Matches the abbreviated month names


(define=> (month-name <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (month-name fws)
    (between-fws-drop (abnf:bind-consumed->string month-name)
		      fws)))


;; Matches a one or two digit number

(define=> (day <CoreABNF>)
  (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  <CoreABNF>)
  (lambda (day month year)
    (abnf:bind-consumed-strings->list 'date 
      (abnf:concatenation day month year))))

;; Matches a two-digit number 

(define=> (hour <CoreABNF>)
  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (minute <CoreABNF>)
  (abnf:bind-consumed->string (abnf:repetition-n 2 decimal)))
(define=> (isecond <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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  <CoreABNF>)
  (lambda (time-of-day zone)
    (abnf:bind-consumed-strings->list 'time 
      (abnf:concatenation time-of-day zone))))

(define=> (date-time <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (dot-atom quoted-string)
    (abnf:alternatives dot-atom quoted-string)))


;; Parses and returns any ASCII characters except [ ] and \

(define=> (dtext <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (phrase)
    (abnf:bind-consumed-pairs->list 'display-name phrase)))

;; Matches an angle-addr, optionally prefaced with a display-name

(define=> (name-addr <CoreABNF>)
  (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  <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (lambda (mailbox-list cfws)
    (abnf:alternatives 
     mailbox-list
     (abnf:drop-consumed cfws))))

;; Matches a single mailbox or an address group 

(define=> (address <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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  <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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 <CoreABNF>)
  (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))
	     (*ctext         (ctext A))
	     (*ccontent      (vac ((ccontent A) *comment *ctext)))
	     (*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-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-<InetMessage> A 
			  *comment fields body message parts 
			  *text *ftext *quoted-string *unstructured
			  *addr-spec *msg-id )

      )))
  

  
)