hsemail-ns 1.3.2 → 1.7.7

raw patch · 9 files changed

+1837/−1533 lines, 9 filesdep +doctestdep +hspecdep ~basenew-uploader

Dependencies added: doctest, hspec

Dependency ranges changed: base

Files

• ChangeLog.md +5/−0
• README +0/−51
• Text/ParserCombinators/Parsec/Rfc2234NS.hs +38/−24
• Text/ParserCombinators/Parsec/Rfc2822NS.hs +1426/−1432
• doc-test.hs +21/−0
• example/message-test.hs +3/−2
• hsemail-ns.cabal +36/−21
• prologue.txt +0/−3
• self-test.hs +308/−0

@@ -0,0 +1,5 @@+## 1.7.7++* Merged with hsemail-1.7.7.++

@@ -1,51 +0,0 @@-Parsers for the Internet Message Standard-=========================================--:Latest Release: hsemail-1.3.tar.gz_-:Darcs:          darcs_ get --partial http://cryp.to/hsemail/--Synopsis-----------  This package contains Parsec_ combinators for the syntax of-  Internet messages, such as e-mail, news articles, namely-  RFC2234, RFC2821, and RFC2822.--  The ``example`` directory contains two small programs that can-  be run as follows::--    $ runhaskell message-test.hs <message-test.input-    $ runhaskell smtp-test.hs <smtp-test.input--Documentation----------------  `Reference Documentation`_-     Haddock-generated reference of all exported functions.--See Also-----------  `librfc2822`_-     An E-mail parser library for C++ programmers.--Copyleft-----------  Copyright (c) 2008 Peter Simons <simons@cryp.to>. All rights-  reserved. This software is released under `BSD-style license-  <LICENSE>`_.---------------------------------------------------------------------`[Homepage] <http://cryp.to/>`_--.. _Parsec: http://www.cs.uu.nl/people/daan/parsec.html--.. _darcs: http://abridgegame.org/darcs/--.. _hsemail-1.3.tar.gz: http://cryp.to/hsemail/hsemail-1.3.tar.gz--.. _Reference Documentation: docs/index.html--.. _librfc2822: http://cryp.to/librfc2822/

@@ -1,9 +1,9 @@ {- |-   Module      :  Text.ParserCombinators.Parsec.Rfc2234NS-   Copyright   :  (c) 2008 Peter Simons+   Module      :  Text.ParserCombinators.Parsec.Rfc2234+   Copyright   :  (c) 2013 Peter Simons    License     :  BSD3 -   Maintainer  :  jfredett@gmail.com+   Maintainer  :  phlummox2@gmail.com    Stability   :  provisional    Portability :  portable @@ -14,21 +14,23 @@    here to avoid conflicts with Parsec's 'char' function.     Addendum for Nonstandard Version:+    This module deviates from the RFC currently in -        * none currently. +        * Allowing for non-standard line endings.+    These allowances are subject to change, and should not be    used when parsing incoming messages, only for parsing messages    that have been stored on disk. The goal of these nonstandard-   Parsers is to provide a higher probability of parsing _common_-   Headers (rather than only those explicitly defined in the RFC)+   parsers is to provide a higher probability of parsing /common/+   headers (rather than only those explicitly defined in the RFC)    as well as allowing for potential oddities / changes that may    occur during storage of an email message. These parsers have    be rebranded so as not to conflict with the standard parsers    available from the excellent 'hsemail' package, upon which    this package depends. For patches to this package only (namely-   'hsemail-ns', patches should be sent to <jfredett@gmail.com>, -   for patches to the Proper parsers, you can send them to the+   'hsemail-ns'), patches should be sent to <phlummox2@gmail.com>, +   for patches to the proper parsers, you can send them to the    original maintainer.   -} @@ -38,6 +40,9 @@ import Data.Char ( toUpper, chr, ord ) import Control.Monad ( liftM2 ) +-- Customize hlint ...+{-# ANN module "HLint: ignore Use camelCase" #-}+ ---------------------------------------------------------------------- -- * Parser Combinators ----------------------------------------------------------------------@@ -85,7 +90,7 @@ -- |Match any character of the alphabet.  alpha           :: CharParser st Char-alpha            = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z']))+alpha            = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z']))                    <?> "alphabetic character"  -- |Match either \"1\" or \"0\".@@ -111,10 +116,19 @@  -- |Match the Internet newline @\\r\\n@. -crlf             :: CharParser st String-crlf             = (choice . map try) [cr >> lf, lf >> cr, cr, lf] >>= return . return -                <?> "eol sequence"+crlf            :: CharParser st String+crlf             = do c <- cr+                      l <- lf+                      return [c,l]+                   <?> "carriage return followed by linefeed" +-- | Non-standard newline - matches any of crlf, lfcr, cr, lf+-- (in that order)+crlfNS          :: CharParser st String+crlfNS          = (choice . map try) [cr >> lf, lf >> cr, cr, lf] >>= +                      return . return +                      <?> "eol sequence"+ -- |Match any US-ASCII control character. That is -- any character with a decimal value in the range of [0..31,127]. @@ -145,7 +159,7 @@ lwsp            :: CharParser st String lwsp             = do r <- choice                            [ many1 wsp-                           , try (liftM2 (++) crlf (many1 wsp))+                           , try (liftM2 (++) crlfNS (many1 wsp))                            ]                       rs <- option [] lwsp                       return (r ++ rs)@@ -179,22 +193,22 @@ -- |Match a \"quoted pair\". Any characters (excluding CR and -- LF) may be quoted. -quotedPair     :: CharParser st String-quotedPair      = do char '\\'-                     r <- noneOf "\r\n"-                     return ['\\',r]-               <?> "quoted pair"+quoted_pair     :: CharParser st String+quoted_pair      = do _ <- char '\\'+                      r <- noneOf "\r\n"+                      return ['\\',r]+                   <?> "quoted pair"  -- |Match a quoted string. The specials \"@\\@\" and -- \"@\"@\" must be escaped inside a quoted string; CR and -- LF are not allowed at all. -quotedString   :: CharParser st String-quotedString    = do dquote-                     r <- many qcont-                     dquote-                     return ("\"" ++ concat r ++ "\"")+quoted_string   :: CharParser st String+quoted_string    = do _ <- dquote+                      r <- many qcont+                      _ <- dquote+                      return ("\"" ++ concat r ++ "\"")                    <?> "quoted string"   where   qtext = noneOf "\\\"\r\n"-  qcont = many1 qtext <|> quotedPair+  qcont = many1 qtext <|> quoted_pair

@@ -1,1434 +1,1428 @@ {- |    Module      :  Text.ParserCombinators.Parsec.Rfc2822-   Copyright   :  (c) 2008 Peter Simons-   License     :  BSD3--   Maintainer  :  simons@cryp.to-   Stability   :  provisional-   Portability :  portable--   This module provides parsers for the grammar defined in-   RFC2822, \"Internet Message Format\",-   <http://www.faqs.org/rfcs/rfc2822.html>.--   /Please note:/ The module is not particularly well tested.---   Addendum for Nonstandard Version:-   This module deviates from the RFC currently in -        * Allowing for non-standard line endings.--   These allowances are subject to change, and should not be-   used when parsing incoming messages, only for parsing messages-   that have been stored on disk. The goal of these nonstandard-   Parsers is to provide a higher probability of parsing Common_ -   Headers (rather than only those explicitly defined in the RFC)-   as well as allowing for potential oddities / changes that may-   occur during storage of an email message. These parsers have-   be rebranded so as not to conflict with the standard parsers-   available from the excellent 'hsemail' package, upon which-   this package depends. For patches to this package only (namely-   'hsemail-ns', patches should be sent to <jfredett@gmail.com>, -   for patches to the Proper parsers, you can send them to the-   original maintainer. --}--module Text.ParserCombinators.Parsec.Rfc2822NS where--import System.Time-import Data.Char ( ord )-import Data.List ( intersperse )-import Control.Monad ( liftM )-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Rfc2234NS hiding ( quotedPair, quotedString )---- * Useful parser combinators---- |Return @Nothing@ if the given parser doesn't match. This--- combinator is included in the latest parsec distribution as--- @optionMaybe@, but ghc-6.6.1 apparently doesn't have it.--maybeOption    :: GenParser tok st a -> GenParser tok st (Maybe a)-maybeOption     = option Nothing . liftM Just---- |@unfold@ @=@ @between (optional cfws) (optional cfws)@--unfold          :: CharParser a b -> CharParser a b-unfold           = between (optional cfws) (optional cfws)---- |Construct a parser for a message header line from the--- header's name and a parser for the body.--header          :: String -> CharParser a b -> CharParser a b-header n p       = let nameString = caseString (n ++ ":")-                   in-                   between nameString crlf p <?> (n ++ " header line")---- |Like 'header', but allows the obsolete white-space rules.--obsHeader       :: String -> CharParser a b -> CharParser a b-obsHeader  n p   = let nameString = caseString n >> many wsp >> char ':'-                   in-                   between nameString crlf p <?> ("obsolete " ++ n ++ " header line")----- ** Primitive Tokens (section 3.2.1)---- |Match any US-ASCII non-whitespace control character.--noWsCtl         :: CharParser a Char-noWsCtl         = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127]))-                  <?> "US-ASCII non-whitespace control character"---- |Match any US-ASCII character except for @\r@, @\n@.--text            :: CharParser a Char-text            = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127]))-                  <?> "US-ASCII character (excluding CR and LF)"---- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@.--specials        :: CharParser a Char-specials        = oneOf "()<>[]:;@,.\\\""   <?> "one of ()<>[]:;@,.\\\""----- ** Quoted characters (section 3.2.2)---- |Match a \"quoted pair\". All characters matched by 'text' may be--- quoted. Note that the parsers returns /both/ characters, the--- backslash and the actual content.--quotedPair      :: CharParser a String-quotedPair      = do { char '\\'; r <- text; return ['\\',r] }-                  <?> "quoted pair"----- ** Folding white space and comments (section 3.2.3)---- |Match \"folding whitespace\". That is any combination of 'wsp' and--- 'crlf' followed by 'wsp'.--fws             :: CharParser a String-fws             = do r <- many1 $ choice [ blanks, linebreak]-                     return (concat r)-    where-    blanks      = many1 wsp-    linebreak   = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) }---- |Match any non-whitespace, non-control character except for \"@(@\",--- \"@)@\", and \"@\\@\". This is used to describe the legal content of--- 'comment's.------ /Note/: This parser accepts 8-bit characters, even though this is--- not legal according to the RFC. Unfortunately, 8-bit content in--- comments has become fairly common in the real world, so we'll just--- accept the fact.--ctext           :: CharParser a Char-ctext           = noWsCtl   <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255]))-                  <?> "any regular character (excluding '(', ')', and '\\')"---- |Match a \"comments\". That is any combination of 'ctext',--- 'quotedPair 's, and 'fws' between brackets. Comments may nest.--comment         :: CharParser a String-comment         = do char '('-                     r1 <- many ccontent-                     r2 <- option [] fws-                     char ')'-                     return ("(" ++ concat r1 ++ r2 ++ ")")-                  <?> "comment"-    where-    ccontent    = try $ do r1 <- option [] fws-                           r2 <- choice [many1 ctext, quotedPair , comment]-                           return (r1 ++ r2)---- |Match any combination of 'fws' and 'comments'.--cfws            :: CharParser a String-cfws            = do r <- many1 $ choice [ fws, comment ]-                     return (concat r)---- ** Atom (section 3.2.4)---- |Match any US-ASCII character except for control characters,--- 'specials', or space. 'atom' and 'dotAtom' are made up of this. --atext           :: CharParser a Char-atext           = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"-                  <?> "US-ASCII character (excluding controls, space, and specials)"---- |Match one or more 'atext' characters and skip any preceeding or--- trailing 'cfws'.--atom            :: CharParser a String-atom            = unfold (many1 atext <?> "atom")---- |Match 'dotAtomText' and skip any preceeding or trailing 'cfws'. --dotAtom        :: CharParser a String -dotAtom        = unfold (dotAtomText <?> "dot atom") ---- |Match two or more 'atext's interspersed by dots.--dotAtomText   :: CharParser a String -dotAtomText   = do r <- sepBy1 (many1 atext) (char '.') -                   return (concat (intersperse "." r))-                 <?> "dot atom content"----- ** Quoted strings (section 3.2.5)---- |Match any non-whitespace, non-control US-ASCII character except--- for \"@\\@\" and \"@\"@\".--qtext           :: CharParser a Char-qtext            = noWsCtl   <|> satisfy (\c -> ord c `elem` ([33] ++ [35..91] ++ [93..126]))-                <?> "US-ASCII character (excluding '\\', and '\"')"---- |Match either 'qtext' or 'quotedPair '.--qcontent        :: CharParser a String-qcontent        = many1 qtext <|> quotedPair -               <?> "quoted string content"---- |Match any number of 'qcontent' between double quotes. Any 'cfws'--- preceeding or following the \"atom\" is skipped automatically.--quotedString   :: CharParser a String-quotedString    = unfold (do dquote-                             r1 <- many (do r1 <- option [] fws-                                            r2 <- qcontent-                                            return (r1 ++ r2))-                             r2 <- option [] fws-                             dquote-                             return ("\"" ++ concat r1 ++ r2 ++ "\""))-                  <?> "quoted string"----- * Miscellaneous tokens (section 3.2.6)---- |Match either 'atom' or 'quotedString'.--word            :: CharParser a String-word            = atom <|> quotedString     <?> "word"---- |Match either one or more 'word's or an 'obsPhrase'.--phrase          :: CharParser a [String]-phrase          = {- many1 word <?> "phrase" <|> -} obsPhrase---- |Match any non-whitespace, non-control US-ASCII character except--- for \"@\\@\" and \"@\"@\".--utext           :: CharParser a Char-utext           = noWsCtl   <|> satisfy (\c -> ord c `elem` [33..126])-                  <?> "regular US-ASCII character (excluding '\\', and '\"')"---- |Match any number of 'utext' tokens.------ \"Unstructured text\" is used in free text fields such as 'subject'.--- Please note that any comments or whitespace that prefaces or--- follows the actual 'utext' is /included/ in the returned string.--unstructured    :: CharParser a String-unstructured    = do r1 <- option [] fws-                     r2 <- many (do r3 <- utext-                                    r4 <- option [] fws-                                    return (r3 : r4))-                     return (r1 ++ concat r2)-                  <?> "unstructured text"----- * Date and Time Specification (section 3.3)---- |Parse 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--- returns a 'CalendarTime', which is set to the appropriate values.--- Note, though, that not all fields of 'CalendarTime' will--- necessarily be set correctly! Obviously, when no weekday has been--- provided, the parser will set this field to 'Monday' - regardless--- of whether the day actually is a monday or not. Similarly, the day--- of the year will always be returned as @0@. The timezone name will--- always be empty: @\"\"@.------ Nor will the 'dateTime' parser perform /any/ consistency checking.--- It will accept------ >    40 Apr 2002 13:12 +0100------ as a perfectly valid date.------ In order to get all fields set to meaningful values, and in order--- to verify the date's consistency, you will have to feed it into any--- of the conversion routines provided in "System.Time", such as--- 'toClockTime'. (When doing this, keep in mind that most functions--- return /local time/. This will not necessarily be the time you're--- expecting.)--dateTime       :: CharParser a CalendarTime-dateTime       = do wd <- option Monday (try (do wd <- dayOfWeek -                                                 char ','-                                                 return wd))-                    (y,m,d) <- date-                    fws-                    (td,z) <- time-                    optional cfws-                    return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False)-                 <?> "date/time specification"---- |This parser will match a 'dayName', optionally wrapped in folding--- whitespace, or an 'obsDayOfWeek' and return it's 'Day' value.  --dayOfWeek     :: CharParser a Day -dayOfWeek     = try (between (optional fws) (optional fws) dayName <?> "name of a day-of-the-week") -               <|> obsDayOfWeek  ---- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...)--- and return the appropriate 'Day' value.--dayName        :: CharParser a Day-dayName        =     do { caseString "Mon"; return Monday }-                  <|> do { try (caseString "Tue"); return Tuesday }-                  <|> do { caseString "Wed"; return Wednesday }-                  <|> do { caseString "Thu"; return Thursday }-                  <|> do { caseString "Fri"; return Friday }-                  <|> do { try (caseString "Sat"); return Saturday }-                  <|> do { caseString "Sun"; return Sunday }-                  <?> "name of a day-of-the-week"---- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return--- a tripple of the form (Int,Month,Int) - corresponding to--- (year,month,day).--date            :: CharParser a (Int,Month,Int)-date            = do d <- day-                     m <- month-                     y <- year-                     return (y,m,d)-                  <?> "date specification"---- |This parser will match a four digit number and return it's integer--- value. No range checking is performed.--year            :: CharParser a Int-year            = do y <- manyN 4 digit-                     return (read y :: Int)-                  <?> "year"---- |This parser will match a 'monthName', optionally wrapped in--- folding whitespace, or an 'obsMonth' and return it's 'Month' --- value.--month           :: CharParser a Month-month           =     try (between (optional fws) (optional fws) monthName <?> "month name")-                  <|> obsMonth ----- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...)--- and return the appropriate 'Month' value.--monthName      :: CharParser a Month-monthName      =     do { try (caseString "Jan"); return January }-                  <|> do { caseString "Feb"; return February }-                  <|> do { try (caseString "Mar"); return March }-                  <|> do { try (caseString "Apr"); return April }-                  <|> do { caseString "May"; return May }-                  <|> do { try (caseString "Jun"); return June }-                  <|> do { caseString "Jul"; return July }-                  <|> do { caseString "Aug"; return August }-                  <|> do { caseString "Sep"; return September }-                  <|> do { caseString "Oct"; return October }-                  <|> do { caseString "Nov"; return November }-                  <|> do { caseString "Dec"; return December }-                  <?> "month name"---- |Match either an 'obsDay', or a one or two digit number and return it. --day             :: CharParser a Int-day             =  try (do { optional fws; r <- manyNtoM 1 2 digit; return (read r :: Int) }) <|> obsDay -                   <?> "day"---- |This parser will match a 'timeOfDay' specification followed by a --- 'zone'. It returns the tuple (TimeDiff,Int) corresponding to the--- return values of either parser.--time            :: CharParser a (TimeDiff,Int)-time            = do t <- timeOfDay -                     fws-                     z <- zone-                     return (t,z)-                  <?> "time and zone specification"---- |This parser will match a time-of-day specification of \"@hh:mm@\" or--- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'.--timeOfDay     :: CharParser a TimeDiff -timeOfDay     = do h <- hour -                   char ':'-                   m <- minute-                   s <- option 0 (do { char ':'; second } )-                   return (TimeDiff 0 0 0 h m s 0)-             <?> "time specification"---- |This parser will match a two-digit number and return it's integer--- value. No range checking is performed.--hour            :: CharParser a Int-hour            = do r <- count 2 digit-                     return (read r :: Int)-                  <?> "hour"---- |This parser will match a two-digit number and return it's integer--- value. No range checking is performed.--minute          :: CharParser a Int-minute          = do r <- count 2 digit-                     return (read r :: Int)-                  <?> "minute"---- |This parser will match a two-digit number and return it's integer--- value. No range checking takes place.--second          :: CharParser a Int-second          = do r <- count 2 digit-                     return (read r :: Int)-                  <?> "second"---- |This parser will match a timezone specification of the form--- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in--- seconds as an integer. 'obsZone' is matched as well. --zone            :: CharParser a Int-zone            = (    do char '+'-                          h <- hour-                          m <- minute-                          return (((h*60)+m)*60)-                   <|> do char '-'-                          h <- hour-                          m <- minute-                          return (-((h*60)+m)*60)-                   <?> "time zone"-                  )-                  <|> obsZone ----- * Address Specification (section 3.4)---- |A NameAddr is composed of an optional realname a mandatory--- e-mail 'address'.--data NameAddr = NameAddr { nameAddrName :: Maybe String-                         , nameAddrAddr :: String -                         }-                deriving (Show,Eq)---- |Parse a single 'mailbox' or an address 'group' and return the--- address(es).--address         :: CharParser a [NameAddr]-address         = try (do { r <- mailbox; return [r] }) <|> group-               <?> "address"---- |Parse a 'nameAddr' or an 'addrSpec' and return the  --- address.--mailbox         :: CharParser a NameAddr-mailbox         =  try nameAddr -               <|> liftM (NameAddr Nothing) addrSpec-               <?> "mailbox"---- |Parse an 'angleAddr', optionally prefaced with a 'displayName', --- and return the address.--nameAddr       :: CharParser a NameAddr -nameAddr       = do name <- maybeOption displayName -                    addr <- angleAddr -                    return (NameAddr name addr)-               <?> "name address"---- |Parse an 'angle_addr' or an 'obsAngleAddr' and return the address.  --angleAddr      :: CharParser a String -angleAddr      = try (unfold (do char '<' -                                 r <- addrSpec -                                 char '>'-                                 return r)-                      <?> "angle address"-                     )-                 <|> obsAngleAddr  ---- |Parse a \"group\" of addresses. That is a 'displayName', followed--- by a colon, optionally followed by a 'mailboxList', followed by a --- semicolon. The found address(es) are returned - what may be none.--- Here is an example:------ >    parse group "" "my group: user1@example.org, user2@example.org;"------ This input comes out as:------ >    Right ["user1@example.org","user2@example.org"]--group           :: CharParser a [NameAddr]-group           = do displayName-                     char ':'-                     r <- option [] mailboxList -                     unfold $ char ';'-                     return r-                  <?> "address group"---- |Parse and return a 'phrase'.--displayName    :: CharParser a String-displayName    = phrase >>= return . unwords-                  <?> "display name"---- |Parse a list of 'mailbox' addresses, every two addresses being--- separated by a comma, and return the list of found address(es).--mailboxList    :: CharParser a [NameAddr] -mailboxList    = sepBy mailbox (char ',') <?> "mailbox list" ---- |Parse a list of 'address' addresses, every two addresses being--- separated by a comma, and return the list of found address(es).--addressList    :: CharParser a [NameAddr] -addressList    = do { r <-sepBy address (char ','); return (concat r) } -                  <?> "address list"----- ** Addr-spec specification (section 3.4.1)---- |Parse an \"address specification\". That is a 'localPart', followed--- by an \"@\@@\" character, followed by a 'domain'. Return the complete--- address as 'String', ignoring any whitespace or any comments.--addrSpec       :: CharParser a String -addrSpec       = do r1 <- localPart -                    char '@'-                    r2 <- domain-                    return (r1 ++ "@" ++ r2)-                  <?> "address specification"---- |Parse and return a \"local part\" of an 'addrSpec'. That is either --- a 'dotAtom' or a 'quotedString'. --localPart      :: CharParser a String-localPart      = dotAtom <|> quotedString -                  <?> "address' local part"---- |Parse and return a \"domain part\" of an 'addrSpec'. That is either --- a 'dotAtom' or a 'domainLiteral'.  --domain          :: CharParser a String-domain          = dotAtom <|> domainLiteral  -                  <?> "address' domain part"---- |Parse a \"domain literal\". That is a \"@[@\" character, followed by--- any amount of 'dcontent', followed by a terminating \"@]@\"--- character. The complete string is returned verbatim.--domainLiteral  :: CharParser a String -domainLiteral  = unfold (do char '[' -                            r <- many $ do { optional fws; dcontent }-                            optional fws-                            char ']'-                            return ("[" ++ concat r ++ "]"))-                 <?> "domain literal"---- |Parse and return any characters that are legal in a--- 'domainLiteral'. That is 'dtext' or a 'quotedPair '. --dcontent        :: CharParser a String-dcontent        = many1 dtext <|> quotedPair -                  <?> "domain literal content"---- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and--- \"@\\@\".--dtext           :: CharParser a Char-dtext           = noWsCtl  -                  <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94,127]))-                  <?> "character (excluding '[', ']', and '\\')"----- * Overall message syntax (section 3.5)---- |This data type repesents a parsed Internet Message as defined in--- this RFC. It consists of an arbitrary number of header lines,--- represented in the 'Field' data type, and a message body, which may--- be empty.--data Message = Message [Field] String-      deriving (Show)---- |Parse a complete message as defined by this RFC and it broken down--- into the separate header fields and the message body. Header lines,--- which contain syntax errors, will not cause the parser to abort.--- Rather, these headers will appear as 'OptionalField's (which are--- unparsed) in the resulting 'Message'. A message must be really,--- really badly broken for this parser to fail.------ This behaviour was chosen because it is impossible to predict what--- the user of this module considers to be a fatal error;--- traditionally, parsers are very forgiving when it comes to Internet--- messages.------ If you want to implement a really strict parser, you'll have to put--- the appropriate parser together yourself. You'll find that this is--- rather easy to do. Refer to the 'fields' parser for further details.--message         :: CharParser a Message-message         = do f <- fields-                     b <- option [] (do crlf-                                        body)-                     return (Message f b)---- |This parser will return a message body as specified by this RFC;--- that is basically any number of 'text' characters, which may be--- divided into separate lines by 'crlf'.--body            :: CharParser a String-body            = do r1 <- many (try (do line <- many text-                                         eol <- crlf-                                         return (line ++ eol)))-                     r2 <- many text-                     return (concat r1 ++ r2)----- * Field definitions (section 3.6)---- |This data type represents any of the header fields defined in this--- RFC. Each of the various instances contains with the return value--- of the corresponding parser.--data Field      = OptionalField       String String-                | From                [NameAddr]-                | Sender              NameAddr-                | ReturnPath          String-                | ReplyTo             [NameAddr]-                | To                  [NameAddr]-                | Cc                  [NameAddr]-                | Bcc                 [NameAddr]-                | MessageID           String-                | InReplyTo           [String]-                | References          [String]-                | Subject             String-                | Comments            String-                | Keywords            [[String]]-                | Date                CalendarTime-                | ResentDate          CalendarTime-                | ResentFrom          [NameAddr]-                | ResentSender        NameAddr-                | ResentTo            [NameAddr]-                | ResentCc            [NameAddr]-                | ResentBcc           [NameAddr]-                | ResentMessageID     String-                | ResentReplyTo       [NameAddr]-                | Received            ([(String,String)], CalendarTime)-                | ObsReceived         [(String,String)]-                deriving (Show)---- |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.------ If you look at the implementation of this parser, you will find--- that it uses Parsec's 'try' modifier around /all/ of the fields.--- The idea behind this is that fields, which contain syntax errors,--- fall back to the catch-all 'optionalField'. 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.--fields          :: CharParser a [Field]-fields          = many (    try (do { r <- from; return (From r) })-                        <|> try (do { r <- sender; return (Sender r) })-                        <|> try (do { r <- returnPath; return (ReturnPath r) })-                        <|> try (do { r <- replyTo; return (ReplyTo r) })-                        <|> try (do { r <- to; return (To r) })-                        <|> try (do { r <- cc; return (Cc r) })-                        <|> try (do { r <- bcc; return (Bcc r) })-                        <|> try (do { r <- messageId; return (MessageID r) }) -                        <|> try (do { r <- inReplyTo; return (InReplyTo r) }) -                        <|> try (do { r <- references; return (References r) })-                        <|> try (do { r <- subject; return (Subject r) })-                        <|> try (do { r <- comments; return (Comments r) })-                        <|> try (do { r <- keywords; return (Keywords r) })-                        <|> try (do { r <- origDate; return (Date r) }) -                        <|> try (do { r <- resentDate; return (ResentDate r) }) -                        <|> try (do { r <- resentFrom; return (ResentFrom r) }) -                        <|> try (do { r <- resentSender; return (ResentSender r) }) -                        <|> try (do { r <- resentTo; return (ResentTo r) })-                        <|> try (do { r <- resentCc; return (ResentCc r) }) -                        <|> try (do { r <- resentBcc; return (ResentBcc r) }) -                        <|> try (do { r <- resentMsgId; return (ResentMessageID r) })  -                        <|> try (do { r <- received; return (Received r) })-                         -- catch all-                        <|> (do { (name,cont) <- optionalField; return (OptionalField name cont) }) -                       )----- ** The origination date field (section 3.6.1)---- |Parse a \"@Date:@\" header line and return the date it contains a--- 'CalendarTime'.--origDate       :: CharParser a CalendarTime -origDate       = header "Date" dateTime ----- ** Originator fields (section 3.6.2)---- |Parse a \"@From:@\" header line and return the 'mailboxList' --- address(es) contained in it.--from            :: CharParser a [NameAddr]-from            = header "From" mailboxList ---- |Parse a \"@Sender:@\" header line and return the 'mailbox' address--- contained in it.--sender          :: CharParser a NameAddr-sender          = header "Sender" mailbox---- |Parse a \"@Reply-To:@\" header line and return the 'addressList' --- address(es) contained in it.--replyTo        :: CharParser a [NameAddr]-replyTo        = header "Reply-To" addressList ----- ** Destination address fields (section 3.6.3)---- |Parse a \"@To:@\" header line and return the 'addressList' --- address(es) contained in it.--to              :: CharParser a [NameAddr]-to              = header "To" addressList ---- |Parse a \"@Cc:@\" header line and return the 'addressList' --- address(es) contained in it.--cc              :: CharParser a [NameAddr]-cc              = header "Cc" addressList ---- |Parse a \"@Bcc:@\" header line and return the 'addressList' --- address(es) contained in it.--bcc             :: CharParser a [NameAddr]-bcc             = header "Bcc" (try addressList <|> do { optional cfws; return [] }) ---- ** Identification fields (section 3.6.4)---- |Parse a \"@Message-Id:@\" header line and return the 'msgId' --- contained in it.--messageId      :: CharParser a String -messageId      = header "Message-ID" msgId ---- |Parse a \"@In-Reply-To:@\" header line and return the list of--- 'msgId's contained in it. --inReplyTo     :: CharParser a [String] -inReplyTo     = header "In-Reply-To" (many1 msgId)  ---- |Parse a \"@References:@\" header line and return the list of--- 'msgId's contained in it. --references      :: CharParser a [String]-references      = header "References" (many1 msgId) ---- |Parse a \"@message ID:@\" and return it. A message ID is almost--- identical to an 'angleAddr', but with stricter rules about folding --- and whitespace.--msgId          :: CharParser a String -msgId          = unfold (do char '<' -                            idl <- idLeft -                            char '@'-                            idr <- idRight -                            char '>'-                            return ("<" ++ idl ++ "@" ++ idr ++ ">"))-               <?> "message ID"---- |Parse a \"left ID\" part of a 'msgId'. This is almost identical to --- the 'localPart' of an e-mail address, but with stricter rules--- about folding and whitespace.--idLeft         :: CharParser a String -idLeft         = dotAtomText <|> noFoldQuote    -                  <?> "left part of an message ID"---- |Parse a \"right ID\" part of a 'msgId'. This is almost identical to --- the 'domain' of an e-mail address, but with stricter rules about--- folding and whitespace.--idRight        :: CharParser a String -idRight        = dotAtomText <|> noFoldLiteral    -                  <?> "right part of an message ID"---- |Parse one or more occurences of 'qtext' or 'quotedPair ' and--- return the concatenated string. This makes up the 'idLeft' of a --- 'msgId'. --noFoldQuote   :: CharParser a String  -noFoldQuote   = do dquote  -                   r <- many (many1 qtext <|> quotedPair )-                   dquote-                   return ("\"" ++ concat r ++ "\"")-                 <?> "non-folding quoted string"---- |Parse one or more occurences of 'dtext' or 'quotedPair ' and--- return the concatenated string. This makes up the 'idRight' of a --- 'msgId'. --noFoldLiteral :: CharParser a String  -noFoldLiteral = do char '['  -                   r <- many (many1 dtext <|> quotedPair )-                   char ']'-                   return ("\"" ++ concat r ++ "\"")-                   return ("[" ++ concat r ++ "]")-                 <?> "non-folding domain literal"----- ** Informational fields (section 3.6.5)---- |Parse a \"@Subject:@\" header line and return it's contents verbatim.--subject         :: CharParser a String-subject         = header "Subject" unstructured---- |Parse a \"@Comments:@\" header line and return it's contents verbatim.--comments        :: CharParser a String-comments        = header "Comments" unstructured---- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's--- found. Please not that each phrase is again a list of 'atom's, as--- returned by the 'phrase' parser.--keywords        :: CharParser a [[String]]-keywords        = header "Keywords" (do r1 <- phrase-                                        r2 <- many (do char ','-                                                       phrase)-                                        return (r1:r2))----- ** Resent fields (section 3.6.6)---- |Parse a \"@Resent-Date:@\" header line and return the date it--- contains as 'CalendarTime'.--resentDate     :: CharParser a CalendarTime -resentDate     = header "Resent-Date" dateTime ---- |Parse a \"@Resent-From:@\" header line and return the 'mailboxList' --- address(es) contained in it.--resentFrom     :: CharParser a [NameAddr] -resentFrom     = header "Resent-From" mailboxList  ----- |Parse a \"@Resent-Sender:@\" header line and return the 'mailboxList' --- address(es) contained in it.--resentSender   :: CharParser a NameAddr -resentSender   = header "Resent-Sender" mailbox ----- |Parse a \"@Resent-To:@\" header line and return the 'mailbox'--- address contained in it.--resentTo       :: CharParser a [NameAddr]-resentTo       = header "Resent-To" addressList ---- |Parse a \"@Resent-Cc:@\" header line and return the 'addressList' --- address(es) contained in it.--resentCc       :: CharParser a [NameAddr] -resentCc       = header "Resent-Cc" addressList  ---- |Parse a \"@Resent-Bcc:@\" header line and return the 'addressList' --- address(es) contained in it. (This list may be empty.)--resentBcc      :: CharParser a [NameAddr] -resentBcc      = header "Resent-Bcc" (    try addressList  -                                       <|> do optional cfws-                                              return []-                                      )-                  <?> "Resent-Bcc: header line"---- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msgId' --- contained in it.--resentMsgId   :: CharParser a String  -resentMsgId   = header "Resent-Message-ID" msgId  ----- ** Trace fields (section 3.6.7)--returnPath     :: CharParser a String-returnPath     = header "Return-Path:" path--path            :: CharParser a String-path            = unfold (    do char '<'-                                 r <- choice [ try addrSpec, do { cfws; return [] } ] -                                 char '>'-                                 return ("<" ++ r ++ ">")-                          <|> obsPath-                         )-                  <?> "return path spec"--received        :: CharParser a ([(String,String)], CalendarTime)-received        = header "Received" (do r1 <- nameValList  -                                        char ';'-                                        r2 <- dateTime-                                        return (r1,r2))--nameValList   :: CharParser a [(String,String)]  -nameValList   = do optional cfws  -                   many1 nameValPair -                  <?> "list of name/value pairs"--nameValPair   :: CharParser a (String,String) -nameValPair   = do r1 <- itemName -                   cfws-                   r2 <- itemValue -                   return (r1,r2)-                  <?> "a name/value pair"--itemName       :: CharParser a String-itemName       = do r1 <- alpha-                    r2 <- many $ choice [ char '-', alpha, digit ]-                    return (r1 : r2)-                  <?> "name of a name/value pair"--itemValue      :: CharParser a String -itemValue      = choice [ try (do { r <- many1 angleAddr; return (concat r) })  -                        , try addrSpec -                        , try domain-                        , msgId -                        , try atom-                        ]-                  <?> "value of a name/value pair"---- ** Optional fields (section 3.6.8)---- |Parse an arbitrary header field and return a tuple containing the--- 'fieldName' and 'unstructured' text of the header. The name will--- /not/ contain the terminating colon.--optionalField  :: CharParser a (String,String) -optionalField  = do n <- fieldName -                    char ':'-                    b <- unstructured-                    crlf-                    return (n,b)-                  <?> "optional (unspecified) header line"---- |Parse and return an arbitrary header field name. That is one or--- more 'ftext' characters.--fieldName      :: CharParser a String-fieldName      = many1 ftext <?> "header line name"---- |Match and return any ASCII character except for control--- characters, whitespace, and \"@:@\".--ftext           :: CharParser a Char-ftext           = satisfy (\c -> ord c `elem` ([33..57] ++ [59..126]))-                  <?> "character (excluding controls, space, and ':')"----- * Miscellaneous obsolete tokens (section 4.1)---- |Match the obsolete \"quoted pair\" syntax, which - unlike--- 'quotedPair ' - allowed /any/ ASCII character to be specified when--- quoted. The parser will return both, the backslash and the actual--- character.--obsQp          :: CharParser a String -obsQp          = do char '\\' -                    c <- satisfy (\c -> ord c `elem` [0..127])-                    return ['\\',c]-                 <?> "any quoted US-ASCII character"---- |Match the obsolete \"text\" syntax, which - unlike 'text' - allowed--- \"carriage returns\" and \"linefeeds\". This is really weird; you--- better consult the RFC for details. The parser will return the--- complete string, including those special characters.--obsText        :: CharParser a String-obsText        = do r1 <- many lf-                    r2 <- many cr-                    r3 <- many (do r4 <- obsChar -                                   r5 <- many lf-                                   r6 <- many cr-                                   return (r4 : (r5 ++ r6)))-                    return (r1 ++ r2 ++ concat r3)---- |Match and return the obsolete \"char\" syntax, which - unlike--- 'character' - did not allow \"carriage return\" and \"linefeed\".--obsChar        :: CharParser a Char -obsChar        = satisfy (\c -> ord c `elem` ([0..9] ++ [11,12] ++ [14..127])) -                  <?> "any ASCII character except CR and LF"---- |Match and return the obsolete \"utext\" syntax, which is identical--- to 'obsText'.--obsUtext       :: CharParser a String -obsUtext       = obsText ---- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' ---- allows dots between tokens.--obsPhrase      :: CharParser a [String]-obsPhrase      = do r1 <- word-                    r2 <- many $ choice [ word-                                        , string "."-                                        , do { cfws; return [] }-                                        ]-                    return (r1 : filter (/=[]) r2)---- |Match a  \"phrase list\" syntax and return the list of 'String's--- that make up the phrase. In contrast to a 'phrase', the--- 'obsPhraseList' separates the individual words by commas. This --- syntax is - as you will have guessed - obsolete.--obsPhraseList :: CharParser a [String] -obsPhraseList = do r1 <- many1 (do r <- option [] phrase -                                   unfold $ char ','-                                   return (filter (/=[]) r))-                   r2 <- option [] phrase-                   return (concat r1 ++ r2)-                <|> phrase----- * Obsolete folding white space (section 4.2)---- |Parse and return an \"obsolete fws\" token. That is at least one--- 'wsp' character, followed by an arbitrary number (including zero)--- of 'crlf' followed by at least one more 'wsp' character.--obsFws         :: CharParser a String -obsFws         = do r1 <- many1 wsp -                    r2 <- many (do r3 <- crlf-                                   r4 <- many1 wsp-                                   return (r3 ++ r4))-                    return (r1 ++ concat r2)----- * Obsolete Date and Time (section 4.3)---- |Parse a 'dayName' but allow for the obsolete folding syntax.--obsDayOfWeek :: CharParser a Day  -obsDayOfWeek = unfold dayName <?> "day-of-the-week name"  ---- |Parse a 'year' but allow for a two-digit number (obsolete) and the--- obsolete folding syntax.--obsYear        :: CharParser a Int -obsYear        = unfold (do r <- manyN 2 digit -                            return (normalize (read r :: Int)))-                  <?> "year"-    where-    normalize n-        | n <= 49   = 2000 + n-        | n <= 999  = 1900 + n-        | otherwise = n---- |Parse a 'monthName' but allow for the obsolete folding syntax.--obsMonth       :: CharParser a Month -obsMonth       = between cfws cfws monthName <?> "month name" ---- |Parse a 'day' but allow for the obsolete folding syntax.--obsDay         :: CharParser a Int -obsDay         = unfold day <?> "day" ---- |Parse a 'hour' but allow for the obsolete folding syntax.--obsHour        :: CharParser a Int -obsHour        = unfold hour <?> "hour" ---- |Parse a 'minute' but allow for the obsolete folding syntax.--obsMinute      :: CharParser a Int -obsMinute      = unfold minute <?> "minute" ---- |Parse a 'second' but allow for the obsolete folding syntax.--obsSecond      :: CharParser a Int -obsSecond      = unfold second <?> "second" ---- |Match the obsolete zone names and return the appropriate offset.--obsZone        :: CharParser a Int -obsZone        = choice [ mkZone "UT"  0 -                         , mkZone "GMT" 0-                         , mkZone "EST" (-5)-                         , mkZone "EDT" (-4)-                         , mkZone "CST" (-6)-                         , mkZone "CDT" (-5)-                         , mkZone "MST" (-7)-                         , mkZone "MDT" (-6)-                         , mkZone "PST" (-8)-                         , mkZone "PDT" (-7)-                         , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 }  <?> "military zone spec"-                         , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 }  <?> "military zone spec"-                         , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } <?> "military zone spec"-                         , do { char 'Z'; return 0 }                                    <?> "military zone spec"-                         ]-    where mkZone n o  = try $ do { string n; return (o*60*60) }----- * Obsolete Addressing (section 4.4)---- |This parser will match the \"obsolete angle address\" syntax. This--- construct used to be known as a \"route address\" in earlier RFCs.--- There are two differences between this construct and the--- 'angleAddr': For one - as usual -, the obsolete form allows for --- more liberal insertion of folding whitespace and comments.------ Secondly, and more importantly, angle addresses used to allow the--- (optional) specification of a \"route\". The newer version does not.--- Such a routing address looks like this:------ >    <@example1.org,@example2.org:simons@example.org>------ The parser will return a tuple that - in case of the above address ---- looks like this:------ >    (["example1.org","example2.org"],"simons@example.org")------ The first part contains a list of hosts that constitute the route--- part. This list may be empty! The second part of the tuple is the--- actual 'addrSpec' address. --obsAngleAddr  :: CharParser a String  -obsAngleAddr  = unfold (do char '<'  -                           _ <- option [] obsRoute-                           addr <- addrSpec -                           char '>'-                           return addr)  -- TODO: route is lost here.-                  <?> "obsolete angle address"---- |This parser parses the \"route\" part of 'obsAngleAddr' and  --- returns the list of 'String's that make up this route. Relies on--- 'obsDomainList' for the actual parsing.  --obsRoute       :: CharParser a [String]-obsRoute       = unfold (do { r <- obsDomainList; char ':'; return r })  -                  <?> "route of an obsolete angle address"---- |This parser parses a list of domain names, each of them prefaced--- with an \"at\". Multiple names are separated by a comma. The list of--- 'domain's is returned - and may be empty.--obsDomainList :: CharParser a [String]  -obsDomainList = do char '@'  -                   r1 <- domain-                   r2 <- many (do cfws <|> string ","-                                  optional cfws-                                  char '@'-                                  domain)-                   return (r1 : r2)-                   <?> "route of an obsolete angle address"---- |Parse the obsolete syntax of a 'localPart', which allowed for--- more liberal insertion of folding whitespace and comments. The--- actual string is returned.--obsLocalPart  :: CharParser a String -obsLocalPart  = do r1 <- word -                   r2 <- many (do string "."-                                  r <- word-                                  return ('.' : r))-                   return (r1 ++ concat r2)-                 <?> "local part of an address"---- |Parse the obsolete syntax of a 'domain', which allowed for more--- liberal insertion of folding whitespace and comments. The actual--- string is returned.--obsDomain      :: CharParser a String -obsDomain      = do r1 <- atom -                    r2 <- many (do string "."-                                   r <- atom-                                   return ('.' : r))-                    return (r1 ++ concat r2)-                  <?> "domain part of an address"---- |This parser will match the obsolete syntax for a 'mailboxList'. --- This one is quite weird: An 'obsMboxList' contains an arbitrary  --- number of 'mailbox'es - including none -, which are separated by--- commas. But you may have multiple consecutive commas without giving--- a 'mailbox'. You may also have a valid 'obsMboxList' that  --- contains /no/ 'mailbox' at all. On the other hand, you /must/ have--- at least one comma.------ So, this input is perfectly valid:------ >    ","------ But this one is - contrary to all intuition - not:------ >    "simons@example.org"------ Strange, isn't it?--obsMboxList   :: CharParser a [NameAddr]  -obsMboxList   = do r1 <- many1 (try (do r <- maybeOption mailbox  -                                        unfold $ char ','-                                        return r))-                   r2 <- maybeOption mailbox-                   return [x | Just x <- r1 ++ [r2]]-                 <?> "obsolete syntax for a list of mailboxes"---- |This parser is identical to 'obsMboxList' but parses a list of  --- 'address'es rather than 'mailbox'es. The main difference is that an--- 'address' may contain 'group's. Please note that as of now, the--- parser will return a simple list of addresses; the grouping--- information is lost.--obsAddrList   :: CharParser a [NameAddr]  -obsAddrList   = do r1 <- many1 (try (do r <- maybeOption address  -                                        optional cfws-                                        char ','-                                        optional cfws-                                        return r))-                   r2 <- maybeOption address-                   return (concat [x | Just x <- r1 ++ [r2]])-                 <?> "obsolete syntax for a list of addresses"----- * Obsolete header fields (section 4.5)--obsFields      :: GenParser Char a [Field] -obsFields      = many (    try (do { r <- obsFrom; return (From r) }) -                        <|> try (do { r <- obsSender; return (Sender r) }) -                        <|> try (do { r <- obsReturn; return (ReturnPath r) })-                        <|> try (do { r <- obsReplyTo; return (ReplyTo r) })-                        <|> try (do { r <- obsTo; return (To r) })-                        <|> try (do { r <- obsCc; return (Cc r) }) -                        <|> try (do { r <- obsBcc; return (Bcc r) }) -                        <|> try (do { r <- obsMessageId; return (MessageID r) })  -                        <|> try (do { r <- obsInReplyTo; return (InReplyTo r) })  -                        <|> try (do { r <- obsReferences; return (References r) })-                        <|> try (do { r <- obsSubject; return (Subject r) }) -                        <|> try (do { r <- obsComments; return (Comments r) }) -                        <|> try (do { r <- obsKeywords; return (Keywords [r]) }) -                        <|> try (do { r <- obsOrigDate; return (Date r) }) -                        <|> try (do { r <- obsResentDate; return (ResentDate r) }) -                        <|> try (do { r <- obsResentFrom; return (ResentFrom r) }) -                        <|> try (do { r <- obsResentSend; return (ResentSender r) }) -                        <|> try (do { r <- obsResentTo; return (ResentTo r) })-                        <|> try (do { r <- obsResentCc; return (ResentCc r) }) -                        <|> try (do { r <- obsResentBcc; return (ResentBcc r) }) -                        <|> try (do { r <- obsResentMid; return (ResentMessageID r) }) -                        <|> try (do { r <- obsResentReply; return (ResentReplyTo r) }) -                        <|> try (do { r <- obsReceived; return (ObsReceived r) })-                         -- catch all-                        <|> (do { (name,cont) <- obsOptional; return (OptionalField name cont) })-                       )----- ** Obsolete origination date field (section 4.5.1)---- |Parse a 'date' header line but allow for the obsolete--- folding syntax.--obsOrigDate   :: CharParser a CalendarTime -obsOrigDate   = obsHeader  "Date" dateTime ----- ** Obsolete originator fields (section 4.5.2)---- |Parse a 'from' header line but allow for the obsolete--- folding syntax.--obsFrom        :: CharParser a [NameAddr] -obsFrom        = obsHeader  "From" mailboxList  ---- |Parse a 'sender' header line but allow for the obsolete--- folding syntax.--obsSender      :: CharParser a NameAddr -obsSender      = obsHeader  "Sender" mailbox ---- |Parse a 'replyTo' header line but allow for the obsolete--- folding syntax.--obsReplyTo    :: CharParser a [NameAddr]-obsReplyTo    = obsHeader  "Reply-To" mailboxList ----- ** Obsolete destination address fields (section 4.5.3)---- |Parse a 'to' header line but allow for the obsolete--- folding syntax.--obsTo          :: CharParser a [NameAddr]-obsTo          = obsHeader  "To" addressList ---- |Parse a 'cc' header line but allow for the obsolete--- folding syntax.--obsCc          :: CharParser a [NameAddr] -obsCc          = obsHeader  "Cc" addressList  ---- |Parse a 'bcc' header line but allow for the obsolete--- folding syntax.--obsBcc         :: CharParser a [NameAddr] -obsBcc         = header "Bcc" (    try addressList  -                                    <|> do { optional cfws; return [] }-                               )----- ** Obsolete identification fields (section 4.5.4)---- |Parse a 'messageId' header line but allow for the obsolete --- folding syntax.--obsMessageId  :: CharParser a String  -obsMessageId  = obsHeader  "Message-ID" msgId  ---- |Parse an 'inReplyTo' header line but allow for the obsolete --- folding and the obsolete phrase syntax.--obsInReplyTo :: CharParser a [String]  -obsInReplyTo = obsHeader  "In-Reply-To" (do r <- many (    do {phrase; return [] }  -                                                     <|> msgId -                                                      )-                                            return (filter (/=[]) r))---- |Parse a 'references' header line but allow for the obsolete--- folding and the obsolete phrase syntax.--obsReferences  :: CharParser a [String]-obsReferences  = obsHeader  "References" (do r <- many (do { phrase; return [] }-                                                       <|> msgId -                                                       )-                                             return (filter (/=[]) r))---- |Parses the \"left part\" of a message ID, but allows the obsolete--- syntax, which is identical to a 'localPart'.--obsIdLeft     :: CharParser a String  -obsIdLeft     = localPart <?> "left part of an message ID"  ---- |Parses the \"right part\" of a message ID, but allows the obsolete--- syntax, which is identical to a 'domain'.--obsIdRight    :: CharParser a String  -obsIdRight    = domain <?> "right part of an message ID"  ------ ** Obsolete informational fields (section 4.5.5)---- |Parse a 'subject' header line but allow for the obsolete--- folding syntax.--obsSubject     :: CharParser a String -obsSubject     = obsHeader  "Subject" unstructured ---- |Parse a 'comments' header line but allow for the obsolete--- folding syntax.--obsComments    :: CharParser a String -obsComments    = obsHeader  "Comments" unstructured ---- |Parse a 'keywords' header line but allow for the obsolete--- folding syntax. Also, this parser accepts 'obsPhraseList'. --obsKeywords    :: CharParser a [String] -obsKeywords    = obsHeader  "Keywords" obsPhraseList  ----- ** Obsolete resent fields (section 4.5.6)---- |Parse a 'resentFrom' header line but allow for the obsolete --- folding syntax.--obsResentFrom :: CharParser a [NameAddr] -obsResentFrom = obsHeader  "Resent-From" mailboxList  ---- |Parse a 'resentSender' header line but allow for the obsolete --- folding syntax.--obsResentSend :: CharParser a NameAddr -obsResentSend = obsHeader  "Resent-Sender" mailbox ---- |Parse a 'resentDate' header line but allow for the obsolete --- folding syntax.--obsResentDate :: CharParser a CalendarTime -obsResentDate = obsHeader  "Resent-Date" dateTime ---- |Parse a 'resentTo' header line but allow for the obsolete--- folding syntax.--obsResentTo   :: CharParser a [NameAddr]-obsResentTo   = obsHeader  "Resent-To" mailboxList ---- |Parse a 'resentCc' header line but allow for the obsolete --- folding syntax.--obsResentCc   :: CharParser a [NameAddr] -obsResentCc   = obsHeader  "Resent-Cc" mailboxList  ---- |Parse a 'resentBcc' header line but allow for the obsolete --- folding syntax.--obsResentBcc  :: CharParser a [NameAddr] -obsResentBcc  = obsHeader  "Bcc" (    try addressList  -                                    <|> do { optional cfws; return [] }-                                   )---- |Parse a 'resentMsgId' header line but allow for the obsolete  --- folding syntax.--obsResentMid  :: CharParser a String -obsResentMid  = obsHeader  "Resent-Message-ID" msgId  ---- |Parse a @Resent-Reply-To@ header line but allow for the--- obsolete folding syntax.--obsResentReply :: CharParser a [NameAddr] -obsResentReply = obsHeader  "Resent-Reply-To" addressList  ----- ** Obsolete trace fields (section 4.5.7)--obsReturn      :: CharParser a String -obsReturn       = obsHeader  "Return-Path" path--obsReceived    :: CharParser a [(String, String)]-obsReceived     = obsHeader  "Received" nameValList  ---- |Match 'obsAngleAddr'.  --obsPath        :: CharParser a String-obsPath        = obsAngleAddr  ---- |This parser is identical to 'optionalField' but allows the more --- liberal line-folding syntax between the \"fieldName\" and the \"field--- text\".--obsOptional    :: CharParser a (String,String)-obsOptional    = do n <- fieldName-                    many wsp-                    char ':'-                    b <- unstructured-                    crlf-                    return (n,b)-                 <?> "optional (unspecified) header line"+   Copyright   :  (c) 2013 Peter Simons+   License     :  BSD3++   Maintainer  :  phlummox2@gmail.com+   Stability   :  provisional+   Portability :  portable++   This module provides parsers for the grammar defined in+   RFC2822, \"Internet Message Format\",+   <http://www.faqs.org/rfcs/rfc2822.html>.++   /Please note:/ The module is not particularly well tested.++   Addendum for Nonstandard Version:++   This module deviates from the RFC currently in ++        * Allowing for non-standard line endings.++   These allowances are subject to change, and should not be+   used when parsing incoming messages, only for parsing messages+   that have been stored on disk. The goal of these nonstandard+   parsers is to provide a higher probability of parsing /common/ +   headers (rather than only those explicitly defined in the RFC)+   as well as allowing for potential oddities / changes that may+   occur during storage of an email message. These parsers have+   be rebranded so as not to conflict with the standard parsers+   available from the excellent 'hsemail' package, upon which+   this package depends. For patches to this package only (namely+   'hsemail-ns'), patches should be sent to <phlummox2@gmail.com>, +   for patches to the proper parsers, you can send them to the+   original maintainer. +-}++module Text.ParserCombinators.Parsec.Rfc2822NS where++import System.Time+import Data.Char ( ord )+import Data.List ( intercalate )+import Data.Maybe ( catMaybes )+import Control.Monad ( liftM )+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Rfc2234NS hiding ( quoted_pair, quoted_string, crlf )+import qualified Text.ParserCombinators.Parsec.Rfc2234NS as Rfc2234++crlf :: CharParser a String +crlf = Rfc2234.crlfNS++-- Customize hlint ...+{-# ANN module "HLint: ignore Use camelCase" #-}++-- * Useful parser combinators++-- |Return @Nothing@ if the given parser doesn't match. This+-- combinator is included in the latest parsec distribution as+-- @optionMaybe@, but ghc-6.6.1 apparently doesn't have it.++maybeOption    :: GenParser tok st a -> GenParser tok st (Maybe a)+maybeOption p   = option Nothing (liftM Just p)++-- |@unfold@ @=@ @between (optional cfws) (optional cfws)@++unfold          :: CharParser a b -> CharParser a b+unfold           = between (optional cfws) (optional cfws)++-- |Construct a parser for a message header line from the+-- header's name and a parser for the body.++header          :: String -> CharParser a b -> CharParser a b+header n p       = let nameString = caseString (n ++ ":")+                   in+                   between nameString crlf p <?> (n ++ " header line")++-- |Like 'header', but allows the obsolete white-space rules.++obs_header      :: String -> CharParser a b -> CharParser a b+obs_header n p   = let nameString = caseString n >> many wsp >> char ':'+                   in+                   between nameString crlf p <?> ("obsolete " ++ n ++ " header line")+++-- ** Primitive Tokens (section 3.2.1)++-- |Match any US-ASCII non-whitespace control character.++no_ws_ctl       :: CharParser a Char+no_ws_ctl       = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127]))+                  <?> "US-ASCII non-whitespace control character"++-- |Match any US-ASCII character except for @\r@, @\n@.++text            :: CharParser a Char+text            = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127]))+                  <?> "US-ASCII character (excluding CR and LF)"++-- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@.++specials        :: CharParser a Char+specials        = oneOf "()<>[]:;@,.\\\""   <?> "one of ()<>[]:;@,.\\\""+++-- ** Quoted characters (section 3.2.2)++-- |Match a \"quoted pair\". All characters matched by 'text' may be+-- quoted. Note that the parsers returns /both/ characters, the+-- backslash and the actual content.++quoted_pair     :: CharParser a String+quoted_pair     = try obs_qp <|> do { _ <- char '\\'; r <- text; return ['\\',r] }+                  <?> "quoted pair"+++-- ** Folding white space and comments (section 3.2.3)++-- |Match \"folding whitespace\". That is any combination of 'wsp' and+-- 'crlf' followed by 'wsp'.++fws             :: CharParser a String+fws             = do r <- many1 $ choice [ blanks, linebreak]+                     return (concat r)+    where+    blanks      = many1 wsp+    linebreak   = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) }++-- |Match any non-whitespace, non-control character except for \"@(@\",+-- \"@)@\", and \"@\\@\". This is used to describe the legal content of+-- 'comment's.+--+-- /Note/: This parser accepts 8-bit characters, even though this is+-- not legal according to the RFC. Unfortunately, 8-bit content in+-- comments has become fairly common in the real world, so we'll just+-- accept the fact.++ctext           :: CharParser a Char+ctext           = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255]))+                  <?> "any regular character (excluding '(', ')', and '\\')"++-- |Match a \"comments\". That is any combination of 'ctext',+-- 'quoted_pair's, and 'fws' between brackets. Comments may nest.++comment         :: CharParser a String+comment         = do _ <- char '('+                     r1 <- many ccontent+                     r2 <- option [] fws+                     _ <- char ')'+                     return ("(" ++ concat r1 ++ r2 ++ ")")+                  <?> "comment"+    where+    ccontent    = try $ do r1 <- option [] fws+                           r2 <- choice [many1 ctext, quoted_pair, comment]+                           return (r1 ++ r2)++-- |Match any combination of 'fws' and 'comments'.++cfws            :: CharParser a String+cfws            = do r <- many1 $ choice [ fws, comment ]+                     return (concat r)++-- ** Atom (section 3.2.4)++-- |Match any US-ASCII character except for control characters,+-- 'specials', or space. 'atom' and 'dot_atom' are made up of this.++atext           :: CharParser a Char+atext           = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"+                  <?> "US-ASCII character (excluding controls, space, and specials)"++-- |Match one or more 'atext' characters and skip any preceeding or+-- trailing 'cfws'.++atom            :: CharParser a String+atom            = unfold (many1 atext <?> "atom")++-- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'.++dot_atom        :: CharParser a String+dot_atom        = unfold (dot_atom_text <?> "dot atom")++-- |Match two or more 'atext's interspersed by dots.++dot_atom_text   :: CharParser a String+dot_atom_text   = fmap (intercalate ".") (sepBy1 (many1 atext) (char '.'))+                  <?> "dot atom content"+++-- ** Quoted strings (section 3.2.5)++-- |Match any non-whitespace, non-control US-ASCII character except+-- for \"@\\@\" and \"@\"@\".++qtext           :: CharParser a Char+qtext           = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33] ++ [35..91] ++ [93..126]))+                  <?> "US-ASCII character (excluding '\\', and '\"')"++-- |Match either 'qtext' or 'quoted_pair'.++qcontent        :: CharParser a String+qcontent        = many1 qtext <|> quoted_pair+                  <?> "quoted string content"++-- |Match any number of 'qcontent' between double quotes. Any 'cfws'+-- preceeding or following the \"atom\" is skipped automatically.++quoted_string   :: CharParser a String+quoted_string   = unfold (do _ <- dquote+                             r1 <- many (do r1 <- option [] fws+                                            r2 <- qcontent+                                            return (r1 ++ r2))+                             r2 <- option [] fws+                             _ <- dquote+                             return ("\"" ++ concat r1 ++ r2 ++ "\""))+                  <?> "quoted string"+++-- * Miscellaneous tokens (section 3.2.6)++-- |Match either 'atom' or 'quoted_string'.++word            :: CharParser a String+word            = unfold (atom <|> quoted_string)     <?> "word"++-- |Match either one or more 'word's or an 'obs_phrase'.++phrase          :: CharParser a [String]+phrase          = {- many1 word <?> "phrase" <|> -} obs_phrase++-- |Match any non-whitespace, non-control US-ASCII character except+-- for \"@\\@\" and \"@\"@\".++utext           :: CharParser a Char+utext           = no_ws_ctl <|> satisfy (\c -> ord c `elem` [33..126])+                  <?> "regular US-ASCII character (excluding '\\', and '\"')"++-- |Match any number of 'utext' tokens.+--+-- \"Unstructured text\" is used in free text fields such as 'subject'.+-- Please note that any comments or whitespace that prefaces or+-- follows the actual 'utext' is /included/ in the returned string.++unstructured    :: CharParser a String+unstructured    = do r1 <- option [] fws+                     r2 <- many (do r3 <- utext+                                    r4 <- option [] fws+                                    return (r3 : r4))+                     return (r1 ++ concat r2)+                  <?> "unstructured text"+++-- * Date and Time Specification (section 3.3)++-- |Parse 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+-- returns a 'CalendarTime', which is set to the appropriate values.+-- Note, though, that not all fields of 'CalendarTime' will+-- necessarily be set correctly! Obviously, when no weekday has been+-- provided, the parser will set this field to 'Monday' - regardless+-- of whether the day actually is a monday or not. Similarly, the day+-- of the year will always be returned as @0@. The timezone name will+-- always be empty: @\"\"@.+--+-- Nor will the 'date_time' parser perform /any/ consistency checking.+-- It will accept+--+-- >    40 Apr 2002 13:12 +0100+--+-- as a perfectly valid date.+--+-- In order to get all fields set to meaningful values, and in order+-- to verify the date's consistency, you will have to feed it into any+-- of the conversion routines provided in "System.Time", such as+-- 'toClockTime'. (When doing this, keep in mind that most functions+-- return /local time/. This will not necessarily be the time you're+-- expecting.)++date_time       :: CharParser a CalendarTime+date_time       = do wd <- option Monday (try (do wd <- day_of_week+                                                  _ <- char ','+                                                  return wd))+                     (y,m,d) <- date+                     _ <- fws+                     (td,z) <- time+                     optional cfws+                     return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False)+                  <?> "date/time specification"++-- |This parser matches a 'day_name' or an 'obs_day_of_week' (optionally+-- wrapped in folding whitespace) and return its 'Day' value.++day_of_week     :: CharParser a Day+day_of_week     =     try (between (optional fws) (optional fws) day_name <?> "name of a day-of-the-week")+                  <|> obs_day_of_week++-- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...)+-- and return the appropriate 'Day' value.++day_name        :: CharParser a Day+day_name        =     do { caseString "Mon"; return Monday }+                  <|> do { try (caseString "Tue"); return Tuesday }+                  <|> do { caseString "Wed"; return Wednesday }+                  <|> do { caseString "Thu"; return Thursday }+                  <|> do { caseString "Fri"; return Friday }+                  <|> do { try (caseString "Sat"); return Saturday }+                  <|> do { caseString "Sun"; return Sunday }+                  <?> "name of a day-of-the-week"++-- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return+-- a tripple of the form (Int,Month,Int) - corresponding to+-- (year,month,day).++date            :: CharParser a (Int,Month,Int)+date            = do d <- day+                     m <- month+                     y <- year+                     return (y,m,d)+                  <?> "date specification"++-- |This parser will match a four digit number and return its integer+-- value. No range checking is performed.++year            :: CharParser a Int+year            = do y <- manyN 4 digit+                     return (read y :: Int)+                  <?> "year"++-- |This parser will match a 'month_name', optionally wrapped in+-- folding whitespace, or an 'obs_month' and return its 'Month'+-- value.++month           :: CharParser a Month+month           =     try (between (optional fws) (optional fws) month_name <?> "month name")+                  <|> obs_month+++-- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...)+-- and return the appropriate 'Month' value.++month_name      :: CharParser a Month+month_name      =     do { try (caseString "Jan"); return January }+                  <|> do { caseString "Feb"; return February }+                  <|> do { try (caseString "Mar"); return March }+                  <|> do { try (caseString "Apr"); return April }+                  <|> do { caseString "May"; return May }+                  <|> do { try (caseString "Jun"); return June }+                  <|> do { caseString "Jul"; return July }+                  <|> do { caseString "Aug"; return August }+                  <|> do { caseString "Sep"; return September }+                  <|> do { caseString "Oct"; return October }+                  <|> do { caseString "Nov"; return November }+                  <|> do { caseString "Dec"; return December }+                  <?> "month name"++-- Internal helper function: match a 1 or 2-digit number (day of month).++day_of_month    :: CharParser a Int+day_of_month    = fmap read (manyNtoM 1 2 digit)++-- |Match a 1 or 2-digit number (day of month), recognizing both+-- standard and obsolete folding syntax.++day             :: CharParser a Int+day             = try obs_day <|> day_of_month <?> "day"++-- |This parser will match a 'time_of_day' specification followed by a+-- 'zone'. It returns the tuple (TimeDiff,Int) corresponding to the+-- return values of either parser.++time            :: CharParser a (TimeDiff,Int)+time            = do t <- time_of_day+                     _ <- fws+                     z <- zone+                     return (t,z)+                  <?> "time and zone specification"++-- |This parser will match a time-of-day specification of \"@hh:mm@\" or+-- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'.++time_of_day     :: CharParser a TimeDiff+time_of_day     = do h <- hour+                     _ <- char ':'+                     m <- minute+                     s <- option 0 (do { _ <- char ':'; second } )+                     return (TimeDiff 0 0 0 h m s 0)+                  <?> "time specification"++-- |This parser will match a two-digit number and return its integer+-- value. No range checking is performed.++hour            :: CharParser a Int+hour            = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "hour"++-- |This parser will match a two-digit number and return its integer+-- value. No range checking is performed.++minute          :: CharParser a Int+minute          = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "minute"++-- |This parser will match a two-digit number and return its integer+-- value. No range checking takes place.++second          :: CharParser a Int+second          = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "second"++-- |This parser will match a timezone specification of the form+-- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in+-- seconds as an integer. 'obs_zone' is matched as well.++zone            :: CharParser a Int+zone            = (    do _ <- char '+'+                          h <- hour+                          m <- minute+                          return (((h*60)+m)*60)+                   <|> do _ <- char '-'+                          h <- hour+                          m <- minute+                          return (-((h*60)+m)*60)+                   <?> "time zone"+                  )+                  <|> obs_zone+++-- * Address Specification (section 3.4)++-- |A NameAddr is composed of an optional realname a mandatory+-- e-mail 'address'.++data NameAddr = NameAddr { nameAddr_name :: Maybe String+                         , nameAddr_addr :: String+                         }+                deriving (Show,Eq)++-- |Parse a single 'mailbox' or an address 'group' and return the+-- address(es).++address         :: CharParser a [NameAddr]+address         = try (do { r <- mailbox; return [r] }) <|> group+                  <?> "address"++-- |Parse a 'name_addr' or an 'addr_spec' and return the+-- address.++mailbox         :: CharParser a NameAddr+mailbox         = try name_addr <|> fmap (NameAddr Nothing) addr_spec+                  <?> "mailbox"++-- |Parse an 'angle_addr', optionally prefaced with a 'display_name',+-- and return the address.++name_addr       :: CharParser a NameAddr+name_addr       = do name <- maybeOption display_name+                     addr <- angle_addr+                     return (NameAddr name addr)+                  <?> "name address"++-- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address.++angle_addr      :: CharParser a String+angle_addr      = try (unfold (do _ <- char '<'+                                  r <- addr_spec+                                  _ <- char '>'+                                  return r)+                       <?> "angle address"+                      )+                  <|> obs_angle_addr++-- |Parse 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:+--+-- >>> parse group "" "my group: user1@example.org, user2@example.org;"+-- Right [NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user1@example.org"},NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user2@example.org"}]++group           :: CharParser a [NameAddr]+group           = do _ <- display_name+                     _ <- char ':'+                     r <- option [] mailbox_list+                     _ <- unfold $ char ';'+                     return r+                  <?> "address group"++-- |Parse and return a 'phrase'.++display_name    :: CharParser a String+display_name    = fmap unwords phrase+                  <?> "display name"++-- |Parse a list of 'mailbox' addresses, every two addresses being+-- separated by a comma, and return the list of found address(es).++mailbox_list    :: CharParser a [NameAddr]+mailbox_list    = sepBy mailbox (char ',') <?> "mailbox list"++-- |Parse a list of 'address' addresses, every two addresses being+-- separated by a comma, and return the list of found address(es).++address_list    :: CharParser a [NameAddr]+address_list    = do { r <-sepBy address (char ','); return (concat r) }+                  <?> "address list"+++-- ** Addr-spec specification (section 3.4.1)++-- |Parse an \"address specification\". That is a 'local_part', followed+-- by an \"@\@@\" character, followed by a 'domain'. Return the complete+-- address as 'String', ignoring any whitespace or any comments.++addr_spec       :: CharParser a String+addr_spec       = do r1 <- local_part+                     _ <- char '@'+                     r2 <- domain+                     return (r1 ++ "@" ++ r2)+                  <?> "address specification"++-- |Parse and return a \"local part\" of an 'addr_spec'. That is either+-- a 'dot_atom' or a 'quoted_string'.++local_part      :: CharParser a String+local_part      = try obs_local_part <|> dot_atom <|> quoted_string+                  <?> "address' local part"++-- |Parse and return a \"domain part\" of an 'addr_spec'. That is either+-- a 'dot_atom' or a 'domain_literal'.++domain          :: CharParser a String+domain          = try obs_domain <|> dot_atom <|> domain_literal+                  <?> "address' domain part"++-- |Parse a \"domain literal\". That is a \"@[@\" character, followed by+-- any amount of 'dcontent', followed by a terminating \"@]@\"+-- character. The complete string is returned verbatim.++domain_literal  :: CharParser a String+domain_literal  = unfold (do _ <- char '['+                             r <- many (optional fws >> dcontent)+                             optional fws+                             _ <- char ']'+                             return ("[" ++ concat r ++ "]"))+                  <?> "domain literal"++-- |Parse and return any characters that are legal in a+-- 'domain_literal'. That is 'dtext' or a 'quoted_pair'.++dcontent        :: CharParser a String+dcontent        = many1 dtext <|> quoted_pair+                  <?> "domain literal content"++-- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and+-- \"@\\@\".++dtext           :: CharParser a Char+dtext           = no_ws_ctl+                  <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94..126]))+                  <?> "any ASCII character (excluding '[', ']', and '\\')"+++-- * Overall message syntax (section 3.5)++-- |This data type repesents a parsed Internet Message as defined in+-- this RFC. It consists of an arbitrary number of header lines,+-- represented in the 'Field' data type, and a message body, which may+-- be empty.++data GenericMessage a = Message [Field] a deriving Show+type Message = GenericMessage String++-- |Parse a complete message as defined by this RFC and it broken down+-- into the separate header fields and the message body. Header lines,+-- which contain syntax errors, will not cause the parser to abort.+-- Rather, these headers will appear as 'OptionalField's (which are+-- unparsed) in the resulting 'Message'. A message must be really,+-- really badly broken for this parser to fail.+--+-- This behaviour was chosen because it is impossible to predict what+-- the user of this module considers to be a fatal error;+-- traditionally, parsers are very forgiving when it comes to Internet+-- messages.+--+-- If you want to implement a really strict parser, you'll have to put+-- the appropriate parser together yourself. You'll find that this is+-- rather easy to do. Refer to the 'fields' parser for further details.++message         :: CharParser a Message+message         = do f <- fields+                     b <- option [] (do _ <- crlf; body)+                     return (Message f b)++-- |A message body is just an unstructured sequence of characters.++body            :: CharParser a String+body            = many anyChar+++-- * Field definitions (section 3.6)++-- |This data type represents any of the header fields defined in this+-- RFC. Each of the various instances contains with the return value+-- of the corresponding parser.++data Field      = OptionalField       String String+                | From                [NameAddr]+                | Sender              NameAddr+                | ReturnPath          String+                | ReplyTo             [NameAddr]+                | To                  [NameAddr]+                | Cc                  [NameAddr]+                | Bcc                 [NameAddr]+                | MessageID           String+                | InReplyTo           [String]+                | References          [String]+                | Subject             String+                | Comments            String+                | Keywords            [[String]]+                | Date                CalendarTime+                | ResentDate          CalendarTime+                | ResentFrom          [NameAddr]+                | ResentSender        NameAddr+                | ResentTo            [NameAddr]+                | ResentCc            [NameAddr]+                | ResentBcc           [NameAddr]+                | ResentMessageID     String+                | ResentReplyTo       [NameAddr]+                | Received            ([(String,String)], CalendarTime)+                | ObsReceived         [(String,String)]+                deriving (Show)++-- |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.+--+-- If you look at the implementation of this parser, you will find+-- that it uses Parsec's 'try' modifier around /all/ of the fields.+-- The idea behind this is that fields, which 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.++fields          :: CharParser a [Field]+fields          = many (    try (do { r <- from; return (From r) })+                        <|> try (do { r <- sender; return (Sender r) })+                        <|> try (do { r <- return_path; return (ReturnPath r) })+                        <|> try (do { r <- reply_to; return (ReplyTo r) })+                        <|> try (do { r <- to; return (To r) })+                        <|> try (do { r <- cc; return (Cc r) })+                        <|> try (do { r <- bcc; return (Bcc r) })+                        <|> try (do { r <- message_id; return (MessageID r) })+                        <|> try (do { r <- in_reply_to; return (InReplyTo r) })+                        <|> try (do { r <- references; return (References r) })+                        <|> try (do { r <- subject; return (Subject r) })+                        <|> try (do { r <- comments; return (Comments r) })+                        <|> try (do { r <- keywords; return (Keywords r) })+                        <|> try (do { r <- orig_date; return (Date r) })+                        <|> try (do { r <- resent_date; return (ResentDate r) })+                        <|> try (do { r <- resent_from; return (ResentFrom r) })+                        <|> try (do { r <- resent_sender; return (ResentSender r) })+                        <|> try (do { r <- resent_to; return (ResentTo r) })+                        <|> try (do { r <- resent_cc; return (ResentCc r) })+                        <|> try (do { r <- resent_bcc; return (ResentBcc r) })+                        <|> try (do { r <- resent_msg_id; return (ResentMessageID r) })+                        <|> try (do { r <- received; return (Received r) })+                         -- catch all+                        <|> (do { (name,cont) <- optional_field; return (OptionalField name cont) })+                       )+++-- ** The origination date field (section 3.6.1)++-- |Parse a \"@Date:@\" header line and return the date it contains a+-- 'CalendarTime'.++orig_date       :: CharParser a CalendarTime+orig_date       = header "Date" date_time+++-- ** Originator fields (section 3.6.2)++-- |Parse a \"@From:@\" header line and return the 'mailbox_list'+-- address(es) contained in it.++from            :: CharParser a [NameAddr]+from            = header "From" mailbox_list++-- |Parse a \"@Sender:@\" header line and return the 'mailbox' address+-- contained in it.++sender          :: CharParser a NameAddr+sender          = header "Sender" mailbox++-- |Parse a \"@Reply-To:@\" header line and return the 'address_list'+-- address(es) contained in it.++reply_to        :: CharParser a [NameAddr]+reply_to        = header "Reply-To" address_list+++-- ** Destination address fields (section 3.6.3)++-- |Parse a \"@To:@\" header line and return the 'address_list'+-- address(es) contained in it.++to              :: CharParser a [NameAddr]+to              = header "To" address_list++-- |Parse a \"@Cc:@\" header line and return the 'address_list'+-- address(es) contained in it.++cc              :: CharParser a [NameAddr]+cc              = header "Cc" address_list++-- |Parse a \"@Bcc:@\" header line and return the 'address_list'+-- address(es) contained in it.++bcc             :: CharParser a [NameAddr]+bcc             = header "Bcc" (try address_list <|> do { optional cfws; return [] })++-- ** Identification fields (section 3.6.4)++-- |Parse a \"@Message-Id:@\" header line and return the 'msg_id'+-- contained in it.++message_id      :: CharParser a String+message_id      = header "Message-ID" msg_id++-- |Parse a \"@In-Reply-To:@\" header line and return the list of+-- 'msg_id's contained in it.++in_reply_to     :: CharParser a [String]+in_reply_to     = header "In-Reply-To" (many1 msg_id)++-- |Parse a \"@References:@\" header line and return the list of+-- 'msg_id's contained in it.++references      :: CharParser a [String]+references      = header "References" (many1 msg_id)++-- |Parse a \"@message ID:@\" and return it. A message ID is almost+-- identical to an 'angle_addr', but with stricter rules about folding+-- and whitespace.++msg_id          :: CharParser a String+msg_id          = unfold (do _ <- char '<'+                             idl <- id_left+                             _ <- char '@'+                             idr <- id_right+                             _ <- char '>'+                             return ("<" ++ idl ++ "@" ++ idr ++ ">"))+                  <?> "message ID"++-- |Parse 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.++id_left         :: CharParser a String+id_left         = dot_atom_text <|> no_fold_quote+                  <?> "left part of an message ID"++-- |Parse 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.++id_right        :: CharParser a String+id_right        = dot_atom_text <|> no_fold_literal+                  <?> "right part of an message ID"++-- |Parse one or more occurences of 'qtext' or 'quoted_pair' and+-- return the concatenated string. This makes up the 'id_left' of a+-- 'msg_id'.++no_fold_quote   :: CharParser a String+no_fold_quote   = do _ <- dquote+                     r <- many (many1 qtext <|> quoted_pair)+                     _ <- dquote+                     return ("\"" ++ concat r ++ "\"")+                  <?> "non-folding quoted string"++-- |Parse one or more occurences of 'dtext' or 'quoted_pair' and+-- return the concatenated string. This makes up the 'id_right' of a+-- 'msg_id'.++no_fold_literal :: CharParser a String+no_fold_literal = do _ <- char '['+                     r <- many (many1 dtext <|> quoted_pair)+                     _ <- char ']'+                     return ("[" ++ concat r ++ "]")+                  <?> "non-folding domain literal"+++-- ** Informational fields (section 3.6.5)++-- |Parse a \"@Subject:@\" header line and return its contents verbatim.+-- Please note that all whitespace and/or comments are preserved, i.e.+-- the result of parsing @\"Subject: foo\"@ is @\" foo\"@, not @\"foo\"@.++subject         :: CharParser a String+subject         = header "Subject" unstructured++-- |Parse a \"@Comments:@\" header line and return its contents verbatim.+-- Please note that all whitespace and/or comments are preserved, i.e.+-- the result of parsing @\"Comments: foo\"@ is @\" foo\"@, not @\"foo\"@.++comments        :: CharParser a String+comments        = header "Comments" unstructured++-- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's+-- found. Please not that each phrase is again a list of 'atom's, as+-- returned by the 'phrase' parser.++keywords        :: CharParser a [[String]]+keywords        = header "Keywords" (do r1 <- phrase+                                        r2 <- many (do _ <- char ','; phrase)+                                        return (r1:r2))+++-- ** Resent fields (section 3.6.6)++-- |Parse a \"@Resent-Date:@\" header line and return the date it+-- contains as 'CalendarTime'.++resent_date     :: CharParser a CalendarTime+resent_date     = header "Resent-Date" date_time++-- |Parse a \"@Resent-From:@\" header line and return the 'mailbox_list'+-- address(es) contained in it.++resent_from     :: CharParser a [NameAddr]+resent_from     = header "Resent-From" mailbox_list+++-- |Parse a \"@Resent-Sender:@\" header line and return the 'mailbox_list'+-- address(es) contained in it.++resent_sender   :: CharParser a NameAddr+resent_sender   = header "Resent-Sender" mailbox+++-- |Parse a \"@Resent-To:@\" header line and return the 'mailbox'+-- address contained in it.++resent_to       :: CharParser a [NameAddr]+resent_to       = header "Resent-To" address_list++-- |Parse a \"@Resent-Cc:@\" header line and return the 'address_list'+-- address(es) contained in it.++resent_cc       :: CharParser a [NameAddr]+resent_cc       = header "Resent-Cc" address_list++-- |Parse a \"@Resent-Bcc:@\" header line and return the 'address_list'+-- address(es) contained in it. (This list may be empty.)++resent_bcc      :: CharParser a [NameAddr]+resent_bcc      = header "Resent-Bcc" (    try address_list+                                       <|> do optional cfws+                                              return []+                                      )+                  <?> "Resent-Bcc: header line"++-- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msg_id'+-- contained in it.++resent_msg_id   :: CharParser a String+resent_msg_id   = header "Resent-Message-ID" msg_id+++-- ** Trace fields (section 3.6.7)++return_path     :: CharParser a String+return_path     = header "Return-Path" path++path            :: CharParser a String+path            = unfold ( try (do _ <- char '<'+                                   r <- option "" addr_spec+                                   _ <- char '>'+                                   return ("<" ++ r ++ ">")+                               )+                          <|> obs_path+                         )+                  <?> "return path spec"++received        :: CharParser a ([(String,String)], CalendarTime)+received        = header "Received" (do r1 <- name_val_list+                                        _ <- char ';'+                                        r2 <- date_time+                                        return (r1,r2))++name_val_list   :: CharParser a [(String,String)]+name_val_list   = do optional cfws+                     many1 name_val_pair+                  <?> "list of name/value pairs"++name_val_pair   :: CharParser a (String,String)+name_val_pair   = do r1 <- item_name+                     _ <- cfws+                     r2 <- item_value+                     return (r1,r2)+                  <?> "a name/value pair"++item_name       :: CharParser a String+item_name       = do r1 <- alpha+                     r2 <- many $ choice [ char '-', alpha, digit ]+                     return (r1 : r2)+                  <?> "name of a name/value pair"++item_value      :: CharParser a String+item_value      = choice [ try (do { r <- many1 angle_addr; return (concat r) })+                         , try addr_spec+                         , try domain+                         , msg_id+                         , try atom+                         ]+                  <?> "value of a name/value pair"++-- ** Optional fields (section 3.6.8)++-- |Parse an arbitrary header field and return a tuple containing the+-- 'field_name' and 'unstructured' text of the header. The name will+-- /not/ contain the terminating colon.++optional_field  :: CharParser a (String,String)+optional_field  = do n <- field_name+                     _ <- char ':'+                     b <- unstructured+                     _ <- crlf+                     return (n,b)+                  <?> "optional (unspecified) header line"++-- |Parse and return an arbitrary header field name. That is one or+-- more 'ftext' characters.++field_name      :: CharParser a String+field_name      = many1 ftext <?> "header line name"++-- |Match and return any ASCII character except for control+-- characters, whitespace, and \"@:@\".++ftext           :: CharParser a Char+ftext           = satisfy (\c -> ord c `elem` ([33..57] ++ [59..126]))+                  <?> "character (excluding controls, space, and ':')"+++-- * Miscellaneous obsolete tokens (section 4.1)++-- |Match the obsolete \"quoted pair\" syntax, which - unlike+-- 'quoted_pair' - allowed /any/ ASCII character to be specified when+-- quoted. The parser will return both, the backslash and the actual+-- character.++obs_qp          :: CharParser a String+obs_qp          = do _ <- char '\\'+                     c <- satisfy (\c -> ord c `elem` [0..127])+                     return ['\\',c]+                  <?> "any quoted US-ASCII character"++-- |Match the obsolete \"text\" syntax, which - unlike 'text' - allowed+-- \"carriage returns\" and \"linefeeds\". This is really weird; you+-- better consult the RFC for details. The parser will return the+-- complete string, including those special characters.++obs_text        :: CharParser a String+obs_text        = do r1 <- many lf+                     r2 <- many cr+                     r3 <- many (do r4 <- obs_char+                                    r5 <- many lf+                                    r6 <- many cr+                                    return (r4 : (r5 ++ r6)))+                     return (r1 ++ r2 ++ concat r3)++-- |Match and return the obsolete \"char\" syntax, which - unlike+-- 'character' - did not allow \"carriage return\" and \"linefeed\".++obs_char        :: CharParser a Char+obs_char        = satisfy (\c -> ord c `elem` ([0..9] ++ [11,12] ++ [14..127]))+                  <?> "any ASCII character except CR and LF"++-- |Match and return the obsolete \"utext\" syntax, which is identical+-- to 'obs_text'.++obs_utext       :: CharParser a String+obs_utext       = obs_text++-- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' -+-- allows dots between tokens.++obs_phrase      :: CharParser a [String]+obs_phrase      = do r1 <- word+                     r2 <- many $ choice [ word+                                         , string "."+                                         , do { _ <- cfws; return [] }+                                         ]+                     return (r1 : filter (/=[]) r2)++-- |Match a  \"phrase list\" syntax and return the list of 'String's+-- that make up the phrase. In contrast to a 'phrase', the+-- 'obs_phrase_list' separates the individual words by commas. This+-- syntax is - as you will have guessed - obsolete.++obs_phrase_list :: CharParser a [String]+obs_phrase_list = do r1 <- many1 (do r <- option [] phrase+                                     _ <- unfold $ char ','+                                     return (filter (/=[]) r))+                     r2 <- option [] phrase+                     return (concat r1 ++ r2)+                  <|> phrase+++-- * Obsolete folding white space (section 4.2)++-- |Parse and return an \"obsolete fws\" token. That is at least one+-- 'wsp' character, followed by an arbitrary number (including zero)+-- of 'crlf' followed by at least one more 'wsp' character.++obs_fws         :: CharParser a String+obs_fws         = do r1 <- many1 wsp+                     r2 <- many (do r3 <- crlf+                                    r4 <- many1 wsp+                                    return (r3 ++ r4))+                     return (r1 ++ concat r2)+++-- * Obsolete Date and Time (section 4.3)++-- |Parse a 'day_name' but allow for the obsolete folding syntax.++obs_day_of_week :: CharParser a Day+obs_day_of_week = unfold day_name <?> "day-of-the-week name"++-- |Parse a 'year' but allow for a two-digit number (obsolete) and the+-- obsolete folding syntax.++obs_year        :: CharParser a Int+obs_year        = unfold (do r <- manyN 2 digit+                             return (normalize (read r :: Int)))+                  <?> "year"+    where+    normalize n+        | n <= 49   = 2000 + n+        | n <= 999  = 1900 + n+        | otherwise = n++-- |Parse a 'month_name' but allow for the obsolete folding syntax.++obs_month       :: CharParser a Month+obs_month       = between cfws cfws month_name <?> "month name"++-- |Parse a 'day' but allow for the obsolete folding syntax.++obs_day         :: CharParser a Int+obs_day         = unfold day_of_month <?> "day"++-- |Parse a 'hour' but allow for the obsolete folding syntax.++obs_hour        :: CharParser a Int+obs_hour        = unfold hour <?> "hour"++-- |Parse a 'minute' but allow for the obsolete folding syntax.++obs_minute      :: CharParser a Int+obs_minute      = unfold minute <?> "minute"++-- |Parse a 'second' but allow for the obsolete folding syntax.++obs_second      :: CharParser a Int+obs_second      = unfold second <?> "second"++-- |Match the obsolete zone names and return the appropriate offset.++obs_zone        :: CharParser a Int+obs_zone        = choice [ mkZone "UT"  0+                         , mkZone "GMT" 0+                         , mkZone "EST" (-5)+                         , mkZone "EDT" (-4)+                         , mkZone "CST" (-6)+                         , mkZone "CDT" (-5)+                         , mkZone "MST" (-7)+                         , mkZone "MDT" (-6)+                         , mkZone "PST" (-8)+                         , mkZone "PDT" (-7)+                         , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 }  <?> "military zone spec"+                         , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 }  <?> "military zone spec"+                         , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } <?> "military zone spec"+                         , do { _ <- char 'Z'; return 0 }                               <?> "military zone spec"+                         ]+    where mkZone n o  = try $ do { _ <- string n; return (o*60*60) }+++-- * Obsolete Addressing (section 4.4)++-- |This parser matches the \"obsolete angle address\" syntax, a construct that+-- used to be called \"route address\" in earlier RFCs. It differs from a+-- standard 'angle_addr' in two ways: (1) it allows far more+-- liberal insertion of folding whitespace and comments and (2) the address may+-- contain a \"route\" (which this parser ignores):+--+-- >>> parse obs_angle_addr "" "<@example1.org,@example2.org:joe@example.org>"+-- Right "<joe@example.org>"++obs_angle_addr  :: CharParser a String+obs_angle_addr  = unfold (do _ <- char '<'+                             _ <- option [] obs_route+                             addr <- addr_spec+                             _ <- char '>'+                             return ("<" ++ addr ++ ">") -- TODO: route is lost here.+                         )+                  <?> "obsolete angle address"++-- |This parser parses the \"route\" part of 'obs_angle_addr' and+-- returns the list of 'String's that make up this route. Relies on+-- 'obs_domain_list' for the actual parsing.++obs_route       :: CharParser a [String]+obs_route       = unfold (do { r <- obs_domain_list; _ <- char ':'; return r })+                  <?> "route of an obsolete angle address"++-- |This parser parses a list of domain names, each of them prefaced+-- with an \"at\". Multiple names are separated by a comma. The list of+-- 'domain's is returned - and may be empty.++obs_domain_list :: CharParser a [String]+obs_domain_list = do _ <- char '@'+                     r1 <- domain+                     r2 <- many (do _ <- cfws <|> string ","+                                    optional cfws+                                    _ <- char '@'+                                    domain)+                     return (r1 : r2)+                    <?> "route of an obsolete angle address"++-- |Parse the obsolete syntax of a 'local_part', which allowed for+-- more liberal insertion of folding whitespace and comments. The+-- actual string is returned.++obs_local_part  :: CharParser a String+obs_local_part  = do r1 <- word+                     r2 <- many (do _ <- string "."+                                    r <- word+                                    return ('.' : r))+                     return (r1 ++ concat r2)+                  <?> "local part of an address"++-- |Parse the obsolete syntax of a 'domain', which allowed for more+-- liberal insertion of folding whitespace and comments. The actual+-- string is returned.++obs_domain      :: CharParser a String+obs_domain      = do r1 <- atom+                     r2 <- many (do _ <- string "."+                                    r <- atom+                                    return ('.' : r))+                     return (r1 ++ concat r2)+                  <?> "domain part of an address"++-- |This parser will match the obsolete syntax for a 'mailbox_list'.+-- This one is quite weird: An 'obs_mbox_list' contains an arbitrary+-- number of 'mailbox'es - including none -, which are separated by+-- commas. But you may have multiple consecutive commas without giving+-- a 'mailbox'. You may also have a valid 'obs_mbox_list' that+-- contains /no/ 'mailbox' at all. On the other hand, you /must/ have+-- at least one comma. The following example is valid:+--+-- >>> parse obs_mbox_list "" ","+-- Right []+--+-- But this one is not:+--+-- >>> parse obs_mbox_list "" "joe@example.org"+-- Left (line 1, column 16):+-- unexpected end of input+-- expecting obsolete syntax for a list of mailboxes++obs_mbox_list   :: CharParser a [NameAddr]+obs_mbox_list   = do r1 <- many1 (try (do r <- maybeOption mailbox+                                          _ <- unfold $ char ','+                                          return r))+                     r2 <- maybeOption mailbox+                     return (catMaybes (r1 ++ [r2]))+                  <?> "obsolete syntax for a list of mailboxes"++-- |This parser is identical to 'obs_mbox_list' but parses a list of+-- 'address'es rather than 'mailbox'es. The main difference is that an+-- 'address' may contain 'group's. Please note that as of now, the+-- parser will return a simple list of addresses; the grouping+-- information is lost.++obs_addr_list   :: CharParser a [NameAddr]+obs_addr_list   = do r1 <- many1 (try (do r <- maybeOption address+                                          optional cfws+                                          _ <- char ','+                                          optional cfws+                                          return r))+                     r2 <- maybeOption address+                     return (concat (catMaybes (r1 ++ [r2])))+                  <?> "obsolete syntax for a list of addresses"+++-- * Obsolete header fields (section 4.5)++obs_fields      :: GenParser Char a [Field]+obs_fields      = many (    try (do { r <- obs_from; return (From r) })+                        <|> try (do { r <- obs_sender; return (Sender r) })+                        <|> try (do { r <- obs_return; return (ReturnPath r) })+                        <|> try (do { r <- obs_reply_to; return (ReplyTo r) })+                        <|> try (do { r <- obs_to; return (To r) })+                        <|> try (do { r <- obs_cc; return (Cc r) })+                        <|> try (do { r <- obs_bcc; return (Bcc r) })+                        <|> try (do { r <- obs_message_id; return (MessageID r) })+                        <|> try (do { r <- obs_in_reply_to; return (InReplyTo r) })+                        <|> try (do { r <- obs_references; return (References r) })+                        <|> try (do { r <- obs_subject; return (Subject r) })+                        <|> try (do { r <- obs_comments; return (Comments r) })+                        <|> try (do { r <- obs_keywords; return (Keywords [r]) })+                        <|> try (do { r <- obs_orig_date; return (Date r) })+                        <|> try (do { r <- obs_resent_date; return (ResentDate r) })+                        <|> try (do { r <- obs_resent_from; return (ResentFrom r) })+                        <|> try (do { r <- obs_resent_send; return (ResentSender r) })+                        <|> try (do { r <- obs_resent_to; return (ResentTo r) })+                        <|> try (do { r <- obs_resent_cc; return (ResentCc r) })+                        <|> try (do { r <- obs_resent_bcc; return (ResentBcc r) })+                        <|> try (do { r <- obs_resent_mid; return (ResentMessageID r) })+                        <|> try (do { r <- obs_resent_reply; return (ResentReplyTo r) })+                        <|> try (do { r <- obs_received; return (ObsReceived r) })+                         -- catch all+                        <|> (do { (name,cont) <- obs_optional; return (OptionalField name cont) })+                       )+++-- ** Obsolete origination date field (section 4.5.1)++-- |Parse a 'date' header line but allow for the obsolete+-- folding syntax.++obs_orig_date   :: CharParser a CalendarTime+obs_orig_date   = obs_header "Date" date_time+++-- ** Obsolete originator fields (section 4.5.2)++-- |Parse a 'from' header line but allow for the obsolete+-- folding syntax.++obs_from        :: CharParser a [NameAddr]+obs_from        = obs_header "From" mailbox_list++-- |Parse a 'sender' header line but allow for the obsolete+-- folding syntax.++obs_sender      :: CharParser a NameAddr+obs_sender      = obs_header "Sender" mailbox++-- |Parse a 'reply_to' header line but allow for the obsolete+-- folding syntax.++obs_reply_to    :: CharParser a [NameAddr]+obs_reply_to    = obs_header "Reply-To" mailbox_list+++-- ** Obsolete destination address fields (section 4.5.3)++-- |Parse a 'to' header line but allow for the obsolete+-- folding syntax.++obs_to          :: CharParser a [NameAddr]+obs_to          = obs_header "To" address_list++-- |Parse a 'cc' header line but allow for the obsolete+-- folding syntax.++obs_cc          :: CharParser a [NameAddr]+obs_cc          = obs_header "Cc" address_list++-- |Parse a 'bcc' header line but allow for the obsolete+-- folding syntax.++obs_bcc         :: CharParser a [NameAddr]+obs_bcc         = header "Bcc" (    try address_list+                                    <|> do { optional cfws; return [] }+                               )+++-- ** Obsolete identification fields (section 4.5.4)++-- |Parse a 'message_id' header line but allow for the obsolete+-- folding syntax.++obs_message_id  :: CharParser a String+obs_message_id  = obs_header "Message-ID" msg_id++-- |Parse an 'in_reply_to' header line but allow for the obsolete+-- folding and the obsolete phrase syntax.++obs_in_reply_to :: CharParser a [String]+obs_in_reply_to = obs_header "In-Reply-To" (do r <- many (    do {_ <- phrase; return [] }+                                                          <|> msg_id+                                                         )+                                               return (filter (/=[]) r))++-- |Parse a 'references' header line but allow for the obsolete+-- folding and the obsolete phrase syntax.++obs_references  :: CharParser a [String]+obs_references  = obs_header "References" (do r <- many (    do { _ <- phrase; return [] }+                                                         <|> msg_id+                                                        )+                                              return (filter (/=[]) r))++-- |Parses the \"left part\" of a message ID, but allows the obsolete+-- syntax, which is identical to a 'local_part'.++obs_id_left     :: CharParser a String+obs_id_left     = local_part <?> "left part of an message ID"++-- |Parses the \"right part\" of a message ID, but allows the obsolete+-- syntax, which is identical to a 'domain'.++obs_id_right    :: CharParser a String+obs_id_right    = domain <?> "right part of an message ID"++++-- ** Obsolete informational fields (section 4.5.5)++-- |Parse a 'subject' header line but allow for the obsolete+-- folding syntax.++obs_subject     :: CharParser a String+obs_subject     = obs_header "Subject" unstructured++-- |Parse a 'comments' header line but allow for the obsolete+-- folding syntax.++obs_comments    :: CharParser a String+obs_comments    = obs_header "Comments" unstructured++-- |Parse a 'keywords' header line but allow for the obsolete+-- folding syntax. Also, this parser accepts 'obs_phrase_list'.++obs_keywords    :: CharParser a [String]+obs_keywords    = obs_header "Keywords" obs_phrase_list+++-- ** Obsolete resent fields (section 4.5.6)++-- |Parse a 'resent_from' header line but allow for the obsolete+-- folding syntax.++obs_resent_from :: CharParser a [NameAddr]+obs_resent_from = obs_header "Resent-From" mailbox_list++-- |Parse a 'resent_sender' header line but allow for the obsolete+-- folding syntax.++obs_resent_send :: CharParser a NameAddr+obs_resent_send = obs_header "Resent-Sender" mailbox++-- |Parse a 'resent_date' header line but allow for the obsolete+-- folding syntax.++obs_resent_date :: CharParser a CalendarTime+obs_resent_date = obs_header "Resent-Date" date_time++-- |Parse a 'resent_to' header line but allow for the obsolete+-- folding syntax.++obs_resent_to   :: CharParser a [NameAddr]+obs_resent_to   = obs_header "Resent-To" mailbox_list++-- |Parse a 'resent_cc' header line but allow for the obsolete+-- folding syntax.++obs_resent_cc   :: CharParser a [NameAddr]+obs_resent_cc   = obs_header "Resent-Cc" mailbox_list++-- |Parse a 'resent_bcc' header line but allow for the obsolete+-- folding syntax.++obs_resent_bcc  :: CharParser a [NameAddr]+obs_resent_bcc  = obs_header "Bcc" (    try address_list+                                    <|> do { optional cfws; return [] }+                                   )++-- |Parse a 'resent_msg_id' header line but allow for the obsolete+-- folding syntax.++obs_resent_mid  :: CharParser a String+obs_resent_mid  = obs_header "Resent-Message-ID" msg_id++-- |Parse a @Resent-Reply-To@ header line but allow for the+-- obsolete folding syntax.++obs_resent_reply :: CharParser a [NameAddr]+obs_resent_reply = obs_header "Resent-Reply-To" address_list+++-- ** Obsolete trace fields (section 4.5.7)++obs_return      :: CharParser a String+obs_return       = obs_header "Return-Path" path++obs_received    :: CharParser a [(String, String)]+obs_received     = obs_header "Received" name_val_list++-- |Match 'obs_angle_addr'.++obs_path        :: CharParser a String+obs_path        = obs_angle_addr++-- |This parser is identical to 'optional_field' but allows the more+-- liberal line-folding syntax between the \"field_name\" and the \"field+-- text\".++obs_optional    :: CharParser a (String,String)+obs_optional    = do n <- field_name+                     _ <- many wsp+                     _ <- char ':'+                     b <- unstructured+                     _ <- crlf+                     return (n,b)+                  <?> "optional (unspecified) header line"

@@ -0,0 +1,21 @@+{-+   Module      :  Main+   Copyright   :  (c) 2013 Peter Simons+   License     :  BSD3++   Maintainer  :  simons@cryp.to+   Stability   :  provisional+   Portability :  portable++   HsEmail doctest suite.+-}++module Main ( main ) where++import Test.DocTest++main :: IO ()+main = doctest+       [ "Text/ParserCombinators/Parsec/Rfc2234NS.hs"+       , "Text/ParserCombinators/Parsec/Rfc2822NS.hs"+       ]

@@ -6,8 +6,9 @@ -- Read an Internet message from standard input, parse it, -- and return the result. -parseEmail s = do-  input <- readFile s+main :: IO ()+main = do+  input <- getContents   print $ parse message "<stdin>" input   return () 

@@ -1,27 +1,42 @@-Name:           hsemail-ns-Version:        1.3.2-Author:         Peter Simons <simons@cryp.to>, Joe Fredette <jfredett@gmail.com>-License:        BSD3-License-file:   LICENSE-Maintainer:     jfredett@gmail.com-Homepage:       http://patch-tag.com/r/hsemail-ns/home-Synopsis:       Internet Message Parsers-Description:    Nonstandard parsers for the syntax defined in RFC2822, forked from hsemail proper. Should not be used for parsing incoming emails, only emails stored on disk.-Category:       Parsing-Cabal-Version: >= 1.2-Build-Type:     Simple-Data-files:-    README,-    prologue.txt,-    example/message-test.hs,-    example/message-test.input+Name:                   hsemail-ns+Version:                1.7.7+Copyright:              (c) 2013 Peter Simons+License:                BSD3+License-File:           LICENSE+Author:                 Peter Simons <simons@cryp.to>, Gero Kriependorf <gero-dev@physra.net>, Marty Pauley <marty@kasei.com>, Joe Fredette <jfredett@gmail.com>, Phlummox <phlummox2@gmail.com>+Maintainer:             phlummox2@gmail.com+Homepage:               https://github.com/phlummox/hsemail-ns/tree/hsemail-ns+Category:               Parsing+Synopsis:               Internet Message Parsers+Description:            Nonstandard parsers for the syntax defined in RFC2822, forked from hsemail proper - permits lf line-ends in addition to crlf. Should not be used for parsing incoming emails, only emails stored on disk.+Cabal-Version:          >= 1.8+Build-Type:             Simple +Extra-Source-Files:     example/message-test.hs+                        example/message-test.input+                        ChangeLog.md++Source-Repository this+  Type:                 git+  Location:             git@github.com:phlummox/hsemail-ns.git+  Branch:               hsemail-ns+  Tag:                  hsemail-ns-v1.7.7+ Library-        Build-Depends:  base<=4, +  Build-Depends:        base >= 3 && < 5,                          mtl,                          parsec,                          old-time+  Exposed-Modules:      Text.ParserCombinators.Parsec.Rfc2234NS,+                        Text.ParserCombinators.Parsec.Rfc2822NS+  Ghc-Options:          -Wall -        Exposed-Modules:-            Text.ParserCombinators.Parsec.Rfc2234NS,-            Text.ParserCombinators.Parsec.Rfc2822NS+Test-Suite test-hsemail+  type:                 exitcode-stdio-1.0+  main-is:              self-test.hs+  build-depends:        base, hspec, parsec, old-time++Test-Suite doctest-hsemail+  type:                 exitcode-stdio-1.0+  main-is:              doc-test.hs+  build-depends:        base, doctest

@@ -1,3 +0,0 @@-This package provides a myriad parsers for Internet messages-as defined in RFC2234, RFC2821, and RFC2822. That would be-e-mail, mostly.

@@ -0,0 +1,308 @@+{-+   Module      :  Main+   Copyright   :  (c) 2013 Peter Simons+   License     :  BSD3++   Maintainer  :  simons@cryp.to+   Stability   :  provisional+   Portability :  portable++   HsEmail regression test suite.+-}++module Main ( main ) where++import Test.Hspec+import System.Time ( CalendarTime(..), Month(..), Day(..) )+import Text.ParserCombinators.Parsec ( parse, eof, CharParser )+import Text.ParserCombinators.Parsec.Rfc2822NS++parseTest :: CharParser () a -> String -> IO a+parseTest p input = case parse (do { r <- p; eof; return r }) (show input) input of+                      Left err -> fail ("parse error at " ++ show err)+                      Right r -> return r++parseIdemTest :: CharParser () String -> String -> Expectation+parseIdemTest p input = parseTest p input `shouldReturn` input++parseFailure :: (Show a) => CharParser () a -> String -> Expectation+parseFailure p input = parse (do { r <- p; eof; return r }) (show input) input `shouldSatisfy` failure+  where+    failure (Left _) = True+    failure _        = False++main :: IO ()+main = hspec $ do+  describe "Rfc2822.quoted_pair" $+    it "can quote a nul byte" $+      parseIdemTest quoted_pair "\\\0"++  describe "Rfc2822.date_time" $+    it "parses hand-picked times correctly" $+      parseTest date_time "Fri, 21 Dec 2012 00:07:43 +0300" `shouldReturn`+        CalendarTime 2012 December 21 0 7 43 0 Friday 0 "" 10800 False++  describe "Rfc2822.day" $ do+    it "parses a hand-picked day-of-months correctly" $ do+      parseTest day "00" `shouldReturn` 0+      parseTest day "09" `shouldReturn` 9+      parseTest day "15" `shouldReturn` 15++    it "does not perform range checking" $+      parseTest day "99" `shouldReturn` 99++    it "fails properly on incomplete input" $ do+      parseFailure day "Mon"+      parseFailure day "Thu"++  describe "Rfc2822.obs_mbox_list" $ do+    it "parses hand-picked inputs correctly" $ do+      parseTest obs_mbox_list "," `shouldReturn` []+      parseTest obs_mbox_list "Joe Doe <joe@example.org>,( \n bla),,jane@\n example.net \n (Jane Doe)," `shouldReturn`+        [NameAddr (Just "Joe Doe") "joe@example.org",NameAddr Nothing "jane@example.net"]++    it "fails properly on incomplete input" $+      parseFailure obs_mbox_list "foo@example.org"++  describe "Rfc2822.subject" $+    it "doesn't consume leading whitespace" $+      parseTest subject "Subject: foo\n" `shouldReturn` " foo"++  describe "Rfc2822.comment" $+    it "doesn't consume leading whitespace" $+      parseTest comments "Comments: foo\n" `shouldReturn` " foo"++  -- Most of the following test cases have been adapted from+  -- <http://hackage.haskell.org/package/email-validate>.+  describe "Rfc2822.addr_spec" $+    it "parses hand-picked inputs correctly" $ do+      parseFailure addr_spec "()[]\\;:,><@example.com" -- Disallowed Characters+      parseFailure addr_spec " -- test --@example.com" -- No spaces allowed in local part+      parseFailure addr_spec "-@..com"+      parseFailure addr_spec "-@a..com"+      parseFailure addr_spec ".@"+      parseFailure addr_spec ".@example.com" -- Phil Haack says so+      parseFailure addr_spec ".dot@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec ".first.last@example.com" -- Local part starts with a dot+      parseFailure addr_spec ".test@example.com"+      parseFailure addr_spec ".wooly@example.com" -- Phil Haack says so+      parseFailure addr_spec "@@bar.com"+      parseFailure addr_spec "@NotAnEmail" -- Phil Haack says so+      parseFailure addr_spec "@bar.com"+      parseFailure addr_spec "@example.com" -- No local part+      parseFailure addr_spec "Abc\\@def@example.com" -- Was incorrectly given as a valid address in the original RFC3696+      parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ L\\.@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ Lovell@example.com" -- Escaping can only happen in a quoted string+      parseFailure addr_spec "Fred\\ Bloggs@example.com" -- Was incorrectly given as a valid address in the original RFC3696+      parseFailure addr_spec "Ima Fool@example.com" -- Phil Haack says so+      parseFailure addr_spec "Invalid \\\n Folding \\\n Whitespace@example.com" -- This isn't FWS so Dominic Sayers says it's invalid+      parseFailure addr_spec "Joe.\\\\Blow@example.com" -- Was incorrectly given as a valid address in the original RFC3696+      parseFailure addr_spec "NotAnEmail" -- Phil Haack says so+      parseFailure addr_spec "[test]@example.com" -- Square brackets only allowed within quotes+      parseFailure addr_spec "\"Doug \"Ace\" L.\"@example.com" -- Doug Lovell says this should fail+      parseIdemTest addr_spec "\"\"@example.com"+      parseFailure addr_spec "\"\"\"@example.com" -- Local part contains unescaped excluded characters+      parseFailure addr_spec "\"\\\"@example.com" -- Local part cannot end with a backslash+      parseFailure addr_spec "\"first\"last\"@example.com" -- Local part contains unescaped excluded characters+      parseFailure addr_spec "\"first\\\\\"last\"@example.com" -- Contains an unescaped quote+      parseFailure addr_spec "\"foo\"(yay)@(hoopla)[1.2.3.4]" -- Address literal can't be commented (RFC5321)+      parseFailure addr_spec "\"null \NUL\"@char.com" -- cannot have unescaped null character+      parseFailure addr_spec "\"qu@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "\"test\"blah\"@example.com" -- Phil Haack says so+      parseFailure addr_spec "\"test\"test\"@example.com" -- Quotes cannot be nested+      --parseFailure addr_spec "\"test\\\n blah\"@example.com" -- Folding white space can't appear within a quoted pair -- XX removed, failing.+      parseFailure addr_spec "\"test\rblah\"@example.com" -- Quoted string specifically excludes carriage returns+      parseFailure addr_spec "a(a(b(c)d(e(f))g)(h(i)j)@example.com" -- Braces are not properly matched+      parseFailure addr_spec "a@bar.com."+      parseFailure addr_spec "aaa.com"+      parseFailure addr_spec "aaa@.123"+      parseFailure addr_spec "aaa@.com"+      parseFailure addr_spec "aaa@[123.123.123.123]a" -- extra data outside ip+      parseFailure addr_spec "abc@def@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "abc\\@def@example.com" -- This example from RFC3696 was corrected in an erratum+      parseFailure addr_spec "abc\\@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "abc\\\\@def@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "abc\\\\@example.com" -- This example from RFC3696 was corrected in an erratum+      parseFailure addr_spec "cal(foo(bar)@iamcal.com" -- Unclosed parenthesis in comment+      parseFailure addr_spec "cal(foo)bar)@iamcal.com" -- Too many closing parentheses+      parseFailure addr_spec "cal(foo\\)@iamcal.com" -- Backslash at end of comment has nothing to escape+      parseFailure addr_spec "dot.@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "doug@" -- Doug Lovell says this should fail+      parseFailure addr_spec "first(12345678901234567890123456789012345678901234567890)last@(1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890)example.com" -- Too long with comments, not too long without+      parseFailure addr_spec "first(abc(\"def\".ghi).mno)middle(abc(\"def\".ghi).mno).last@(abc(\"def\".ghi).mno)example(abc(\"def\".ghi).mno).(abc(\"def\".ghi).mno)com(abc(\"def\".ghi).mno)" -- Can't have comments or white space except at an element boundary+      parseFailure addr_spec "first(middle)last@example.com" -- Can't have a comment or white space except at an element boundary+      parseFailure addr_spec "first..last@example.com" -- Local part has consecutive dots+      parseFailure addr_spec "first.last" -- No @+      parseFailure addr_spec "first.last.@example.com" -- Local part ends with a dot+      parseFailure addr_spec "first.last@" -- No domain+      parseFailure addr_spec "first\\@last@example.com" -- Escaping can only happen within a quoted string+      parseFailure addr_spec "first\\\\@last@example.com" -- Local part contains unescaped excluded characters+      parseFailure addr_spec "first\\last@example.com" -- Unquoted string must be an atom+      parseFailure addr_spec "gatsby@f.sc.ot.t.f.i.tzg.era.l.d." -- Doug Lovell says this should fail+      parseFailure addr_spec "hello world@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "ote\"@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "phil.h\\@\\@ck@haacked.com" -- Escaping can only happen in a quoted string+      parseFailure addr_spec "pootietang.@example.com" -- Phil Haack says so+      parseFailure addr_spec "test..test@example.com"+      parseFailure addr_spec "test.@example.com"+      parseFailure addr_spec "test.\n\n obs@syntax.com" -- obs-fws must have at least one WSP per line+      parseFailure addr_spec "test.example.com"+      parseFailure addr_spec "test@." -- Dave Child says so+      parseFailure addr_spec "test@...........com" -- ......+      parseFailure addr_spec "test@.org" -- Dave Child says so+      parseFailure addr_spec "test@123.123.123.123]" -- Dave Child says so+      parseFailure addr_spec "test@@example.com"+      parseFailure addr_spec "test@[123.123.123.123" -- Dave Child says so+      parseFailure addr_spec "test@example." -- Dave Child says so+      parseFailure addr_spec "test@test@example.com"+      parseFailure addr_spec "two..dot@example.com" -- Doug Lovell says this should fail+      parseFailure addr_spec "wo..oly@example.com" -- Phil Haack says so+      parseFailure addr_spec "{^c\\@**Dog^}@cartoon.com" -- This is a throwaway example from Doug Lovell's article. Actually it's not a valid address.+      parseTest addr_spec " \n (\n x \n ) \n first\n ( \n x\n ) \n .\n ( \n x) \n last \n (  x \n ) \n @example.com" `shouldReturn` "first.last@example.com"+      parseIdemTest addr_spec "!def!xyz%abc@example.com"+      parseIdemTest addr_spec "$A12345@example.com"+      parseTest addr_spec "(foo)cal(bar)@(baz)iamcal.com(quux)" `shouldReturn` "cal@iamcal.com"+      parseIdemTest addr_spec "+1~1+@example.com"+      parseIdemTest addr_spec "+@b.c" -- TLDs can be any length+      parseIdemTest addr_spec "+@b.com"+      parseTest addr_spec "1234   @   local(blah)  .machine .example" `shouldReturn` "1234@local.machine.example"+      parseIdemTest addr_spec "1234567890123456789012345678901234567890123456789012345678901234@example.com"+      parseIdemTest addr_spec "123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.123456789012345678901234567890123456789012345678901234567890123.example.com"+      parseIdemTest addr_spec "1234567890@example.com"+      parseTest addr_spec "HM2Kinsists@(that comments are allowed)this.is.ok" `shouldReturn` "HM2Kinsists@this.is.ok"+      parseIdemTest addr_spec "Ima.Fool@example.com"+      parseIdemTest addr_spec "TEST@example.com"+      parseTest addr_spec "Test.\n Folding.\n Whitespace@example.com" `shouldReturn` "Test.Folding.Whitespace@example.com"+      parseIdemTest addr_spec "\"Abc@def\"@example.com"+      parseIdemTest addr_spec "\"Abc\\@def\"@example.com"+      parseIdemTest addr_spec "\"Austin@Powers\"@example.com"+      parseIdemTest addr_spec "\"Doug \\\"Ace\\\" L.\"@example.com"+      parseIdemTest addr_spec "\"Fred Bloggs\"@example.com"+      parseIdemTest addr_spec "\"Fred\\ Bloggs\"@example.com"+      parseIdemTest addr_spec "\"Ima Fool\"@example.com"+      parseIdemTest addr_spec "\"Ima.Fool\"@example.com"+      parseIdemTest addr_spec "\"Joe.\\\\Blow\"@example.com"+      parseIdemTest addr_spec "\"Joe\\\\Blow\"@example.com"+      parseIdemTest addr_spec "\"Test \\\"Fail\\\" Ing\"@example.com"+      parseIdemTest addr_spec "\"[[ test ]]\"@example.com"+      parseIdemTest addr_spec "\"first last\"@example.com"+      parseIdemTest addr_spec "\"first(last)\"@example.com"+      parseIdemTest addr_spec "\"first..last\"@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "\"first.middle.last\"@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "\"first.middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "\"first@last\"@example.com"+      parseIdemTest addr_spec "\"first\".\"last\"@example.com"+      parseIdemTest addr_spec "\"first\".\"middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "\"first\".last@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "\"first\".middle.\"last\"@example.com"+      parseIdemTest addr_spec "\"first\\\"last\"@example.com"+      parseIdemTest addr_spec "\"first\\\\\\\"last\"@example.com"+      parseIdemTest addr_spec "\"first\\\\last\"@example.com"+      parseIdemTest addr_spec "\"first\\last\"@example.com" -- Any character can be escaped in a quoted string+      parseIdemTest addr_spec "\"hello my name is\"@stutter.com"+      parseIdemTest addr_spec "\"null \\\NUL\"@char.com" -- can have escaped null character+      parseIdemTest addr_spec "\"test.test\"@example.com"+      parseIdemTest addr_spec "\"test@test\"@example.com"+      parseIdemTest addr_spec "\"test\\\"blah\"@example.com"+      parseIdemTest addr_spec "\"test\\\\blah\"@example.com"+      parseIdemTest addr_spec "\"test\\\rblah\"@example.com" -- Quoted string specifically excludes carriage returns unless escaped+      parseIdemTest addr_spec "\"test\\blah\"@example.com" -- Any character can be escaped in a quoted string+      parseIdemTest addr_spec "\"test\\test\"@example.com" -- Any character can be escaped in a quoted string+      parseIdemTest addr_spec "\"test\n blah\"@example.com" -- This is a valid quoted string with folding white space+      parseIdemTest addr_spec "_Yosemite.Sam@example.com"+      parseIdemTest addr_spec "_somename@example.com"+      parseTest addr_spec "a(a(b(c)d(e(f))g)h(i)j)@example.com" `shouldReturn` "a@example.com"+      parseIdemTest addr_spec "a-b@bar.com"+      parseIdemTest addr_spec "a@b.co-foo.uk"+      parseIdemTest addr_spec "a@bar.com"+      parseIdemTest addr_spec "aaa@[123.123.123.123]"+      parseTest addr_spec "c@(Chris's host.)public.example" `shouldReturn` "c@public.example"+      parseTest addr_spec "cal(foo\\)bar)@iamcal.com"       `shouldReturn` "cal@iamcal.com"+      parseTest addr_spec "cal(foo\\@bar)@iamcal.com"       `shouldReturn` "cal@iamcal.com"+      parseTest addr_spec "cal(woo(yay)hoopla)@iamcal.com"  `shouldReturn` "cal@iamcal.com"+      parseTest addr_spec "cal@iamcal(woo).(yay)com"        `shouldReturn` "cal@iamcal.com"+      parseIdemTest addr_spec "customer/department=shipping@example.com"+      parseIdemTest addr_spec "customer/department@example.com"+      parseIdemTest addr_spec "dclo@us.ibm.com"+      parseTest addr_spec "first().last@example.com" `shouldReturn` "first.last@example.com"+      parseTest addr_spec "first(Welcome to\n the (\"wonderful\" (!)) world\n of email)@example.com" `shouldReturn` "first@example.com"+      parseTest addr_spec "first(a\"bc.def).last@example.com" `shouldReturn` "first.last@example.com"+      parseTest addr_spec "first(abc.def).last@example.com" `shouldReturn` "first.last@example.com"+      parseTest addr_spec "first(abc\\(def)@example.com" `shouldReturn` "first@example.com"+      parseTest addr_spec "first.(\")middle.last(\")@example.com" `shouldReturn` "first.middle.last@example.com"+      parseTest addr_spec "first.(\n middle\n )last@example.com" `shouldReturn` "first.last@example.com"+      parseIdemTest addr_spec "first.\"last\"@example.com" -- obs-local-part form as described in RFC 2822+      parseIdemTest addr_spec "first.\"mid\\dle\".\"last\"@example.com" -- Backslash can escape anything but must escape something+      parseIdemTest addr_spec "first.last@123.example.com"+      parseIdemTest addr_spec "first.last@1xample.com"+      parseIdemTest addr_spec "first.last@[12.34.56.78]"+      parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.56.78]"+      parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]"+      parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666::]"+      parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:12.34.56.78]"+      parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:5555:6666]"+      parseIdemTest addr_spec "first.last@[IPv6:::1111:2222:3333:4444:5555:6666]"+      parseIdemTest addr_spec "first.last@[IPv6:::12.34.56.78]"+      parseIdemTest addr_spec "first.last@example.com"+      parseTest addr_spec "first.last@x(1234567890123456789012345678901234567890123456789012345678901234567890).com" `shouldReturn` "first.last@x.com"+      parseIdemTest addr_spec "first.last@x23456789012345678901234567890123456789012345678901234567890123.example.com"+      parseTest addr_spec "jdoe@machine(comment).  example" `shouldReturn` "jdoe@machine.example"+      parseIdemTest addr_spec "name.lastname@domain.com"+      parseTest addr_spec "pete(his account)@silly.test(his host)" `shouldReturn` "pete@silly.test"+      parseIdemTest addr_spec "peter.piper@example.com"+      parseIdemTest addr_spec "shaitan@my-domain.thisisminekthx" -- Disagree with Paul Gregg here+      parseIdemTest addr_spec "t*est@example.com"+      parseIdemTest addr_spec "test+test@example.com"+      parseIdemTest addr_spec "test-test@example.com"+      parseTest addr_spec "test. \n \n obs@syntax.com" `shouldReturn` "test.obs@syntax.com"+      parseTest addr_spec "test.\"test\"@example.com" `shouldReturn` "test.\"test\"@example.com"+      parseTest addr_spec "test.\n \n obs@syntax.com" `shouldReturn` "test.obs@syntax.com"+      parseIdemTest addr_spec "test.test@example.com"+      parseIdemTest addr_spec "test@123.123.123.x123"+      parseIdemTest addr_spec "test@[123.123.123.123]"+      parseIdemTest addr_spec "test@example.com"+      parseIdemTest addr_spec "test@example.example.com"+      parseIdemTest addr_spec "test@example.example.example.com"+      parseIdemTest addr_spec "user%uucp!path@somehost.edu"+      parseIdemTest addr_spec "user+mailbox@example.com"+      parseIdemTest addr_spec "valid@special.museum"+      parseIdemTest addr_spec "x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x234"+      parseIdemTest addr_spec "{_test_}@example.com"+      parseIdemTest addr_spec "~@example.com"++  describe "Rfc2822.path" $ do+    it "parses hand-picked inputs correctly" $+      parseTest path "  <joe@example.de>  " `shouldReturn` "<joe@example.de>"+    it "loses the route-part of an obsolete routing address" $+      parseTest path "<@example1.org,@example2.org:joe@example.org>" `shouldReturn` "<joe@example.org>"++  describe "Rfc2822.dot_atom" $ do+    it "consumes leading and trailing whitespace" $+      parseTest dot_atom " first.last " `shouldReturn` "first.last"+    it "does not allow interspersed whitespace" $ do+      parseFailure dot_atom "first . last"+      parseFailure dot_atom "first .last"+      parseFailure dot_atom "first. last"++  describe "Rfc2822.local_part" $ do+    it "consumes leading and trailing whitespace" $+      parseTest local_part " first.last " `shouldReturn` "first.last"+    it "consumes interspersed whitespace (obsolete syntax)" $ do+      parseTest local_part " first . last " `shouldReturn` "first.last"+      parseTest local_part " first .last " `shouldReturn` "first.last"+      parseTest local_part " first. last " `shouldReturn` "first.last"++  describe "Rfc2822.return_path" $ do+    it "parses hand-picked inputs correctly" $ do+      parseTest return_path "Return-Path: <joe@example.de>\n" `shouldReturn` "<joe@example.de>"+      parseTest return_path "Return-Path: <>\n" `shouldReturn` "<>"+    it "loses the route-part of an obsolete routing address" $+      parseTest return_path "Return-Path: <@example1.org,@example2.org:joe@example.org>\n" `shouldReturn` "<joe@example.org>"++  describe "Rfc2822.word" $+    it "parses hand-picked inputs correctly" $+      parseTest word "  foobar  " `shouldReturn` "foobar"++  describe "Rfc2822.body" $+    it "parses 8-bit characters correctly" $+      parseIdemTest body "abc äöüß def"