hsemail 1.7.7 → 2

raw patch · 15 files changed

+2485/−2534 lines, 15 filesdep +hsemaildep ~basedep ~parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: hsemail

Dependency ranges changed: base, parsec

API changes (from Hackage documentation)

Files

• Text/ParserCombinators/Parsec/Rfc2234.hs +0/−187
• Text/ParserCombinators/Parsec/Rfc2821.hs +0/−520
• Text/ParserCombinators/Parsec/Rfc2822.hs +0/−1402
• doc-test.hs +0/−22
• example/message-test.hs +0/−21
• example/message-test.input +0/−20
• example/smtp-test.hs +0/−12
• example/smtp-test.input +0/−7
• hsemail.cabal +67/−35
• self-test.hs +0/−308
• src/Text/Parsec/Rfc2234.hs +190/−0
• src/Text/Parsec/Rfc2821.hs +521/−0
• src/Text/Parsec/Rfc2822.hs +1404/−0
• test/doctest.hs +6/−0
• test/spec.hs +297/−0

@@ -1,187 +0,0 @@-{- |-   Module      :  Text.ParserCombinators.Parsec.Rfc2234-   Copyright   :  (c) 2013 Peter Simons-   License     :  BSD3--   Maintainer  :  simons@cryp.to-   Stability   :  provisional-   Portability :  portable--   This module provides parsers for the grammar defined in-   RFC2234, \"Augmented BNF for Syntax Specifications:-   ABNF\", <http://www.faqs.org/rfcs/rfc2234.html>. The-   terminal called @char@ in the RFC is called 'character'-   here to avoid conflicts with Parsec's 'char' function.- -}--module Text.ParserCombinators.Parsec.Rfc2234 where--import Text.ParserCombinators.Parsec-import Data.Char ( toUpper, chr, ord )-import Control.Monad ( liftM2 )---- Customize hlint ...-{-# ANN module "HLint: ignore Use camelCase" #-}--------------------------------------------------------------------------- * Parser Combinators--------------------------------------------------------------------------- |Case-insensitive variant of Parsec's 'char' function.--caseChar        :: Char -> CharParser st Char-caseChar c       = satisfy (\x -> toUpper x == toUpper c)---- |Case-insensitive variant of Parsec's 'string' function.--caseString      :: String -> CharParser st ()-caseString cs    = mapM_ caseChar cs <?> cs---- |Match a parser at least @n@ times.--manyN           :: Int -> GenParser a b c -> GenParser a b [c]-manyN n p-    | n <= 0     = return []-    | otherwise  = liftM2 (++) (count n p) (many p)---- |Match a parser at least @n@ times, but no more than @m@ times.--manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]-manyNtoM n m p-    | n < 0      = return []-    | n > m      = return []-    | n == m     = count n p-    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))-    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)---- |Helper function to generate 'Parser'-based instances for--- the 'Read' class.--parsec2read :: Parser a -> String -> [(a, String)]-parsec2read f x  = either (error . show) id (parse f' "" x)-  where-  f' = do { a <- f; res <- getInput; return [(a,res)] }---------------------------------------------------------------------------- * Primitive Parsers--------------------------------------------------------------------------- |Match any character of the alphabet.--alpha           :: CharParser st Char-alpha            = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z']))-                   <?> "alphabetic character"---- |Match either \"1\" or \"0\".--bit             :: CharParser st Char-bit              = oneOf "01"   <?> "bit ('0' or '1')"---- |Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is).--character       :: CharParser st Char-character        = satisfy (\c -> (c >= chr 1) && (c <= chr 127))-                   <?> "7-bit character excluding NUL"---- |Match the carriage return character @\\r@.--cr              :: CharParser st Char-cr               = char '\r'    <?> "carriage return"---- |Match returns the linefeed character @\\n@.--lf              :: CharParser st Char-lf               = char '\n'    <?> "linefeed"---- |Match the Internet newline @\\r\\n@.--crlf            :: CharParser st String-crlf             = do c <- cr-                      l <- lf-                      return [c,l]-                   <?> "carriage return followed by linefeed"---- |Match any US-ASCII control character. That is--- any character with a decimal value in the range of [0..31,127].--ctl             :: CharParser st Char-ctl              = satisfy (\c -> ord c `elem` ([0..31] ++ [127]))-                   <?> "control character"---- |Match the double quote character \"@\"@\".--dquote          :: CharParser st Char-dquote           = char (chr 34)    <?> "double quote"---- |Match any character that is valid in a hexadecimal number;--- [\'0\'..\'9\'] and [\'A\'..\'F\',\'a\'..\'f\'] that is.--hexdig          :: CharParser st Char-hexdig           = hexDigit    <?> "hexadecimal digit"---- |Match the tab (\"@\\t@\") character.--htab            :: CharParser st Char-htab             = char '\t'    <?> "horizontal tab"---- |Match \"linear white-space\". That is any number of consecutive--- 'wsp', optionally followed by a 'crlf' and (at least) one more--- 'wsp'.--lwsp            :: CharParser st String-lwsp             = do r <- choice-                           [ many1 wsp-                           , try (liftM2 (++) crlf (many1 wsp))-                           ]-                      rs <- option [] lwsp-                      return (r ++ rs)-                   <?> "linear white-space"---- |Match /any/ character.-octet           :: CharParser st Char-octet            = anyChar    <?> "any 8-bit character"---- |Match the space.--sp              :: CharParser st Char-sp               = char ' '    <?> "space"---- |Match any printable ASCII character. (The \"v\" stands for--- \"visible\".) That is any character in the decimal range of--- [33..126].--vchar           :: CharParser st Char-vchar            = satisfy (\c -> (c >= chr 33) && (c <= chr 126))-                   <?> "printable character"---- |Match either 'sp' or 'htab'.--wsp             :: CharParser st Char-wsp              = sp <|> htab    <?> "white-space"----- ** Useful additions---- |Match a \"quoted pair\". Any characters (excluding CR and--- LF) may be quoted.--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.--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 <|> quoted_pair

@@ -1,520 +0,0 @@-{- |-   Module      :  Text.ParserCombinators.Parsec.Rfc2821-   Copyright   :  (c) 2013 Peter Simons-   License     :  BSD3--   Maintainer  :  simons@cryp.to-   Stability   :  provisional-   Portability :  portable--   This module exports parser combinators for the grammar-   described in RFC2821, \"Simple Mail Transfer Protocol\",-   <http://www.faqs.org/rfcs/rfc2821.html>.--}--module Text.ParserCombinators.Parsec.Rfc2821 where--import Control.Exception ( assert )-import Control.Monad.State-import Text.ParserCombinators.Parsec-import Data.List ( intercalate )-import Data.Char ( toLower )-import Text.ParserCombinators.Parsec.Rfc2234---- Customize hlint ...-{-# ANN module "HLint: ignore Use camelCase" #-}--------------------------------------------------------------------------- * ESMTP State Machine-------------------------------------------------------------------------data SessionState-  = Unknown-  | HaveHelo-  | HaveMailFrom-  | HaveRcptTo-  | HaveData-  | HaveQuit-  deriving (Enum, Bounded, Eq, Ord, Show)--data Event-  = Greeting                    -- ^ reserved for the user-  | SayHelo       String-  | SayHeloAgain  String-  | SayEhlo       String-  | SayEhloAgain  String-  | SetMailFrom   Mailbox-  | AddRcptTo     Mailbox-  | StartData-  | Deliver                     -- ^ reserved for the user-  | NeedHeloFirst-  | NeedMailFromFirst-  | NeedRcptToFirst-  | NotImplemened-        -- ^ 'Turn', 'Send', 'Soml', 'Saml', 'Vrfy', and 'Expn'.-  | ResetState-  | SayOK-        -- ^ Triggered in case of 'Noop' or when 'Rset' is-        -- used before we even have a state.-  | SeeksHelp     String-        -- ^ The parameter may be @[]@.-  | Shutdown-  | SyntaxErrorIn String-  | Unrecognized  String-  deriving (Eq, Show)--type SmtpdFSM = Control.Monad.State.State SessionState Event---- |Parse a line of SMTP dialogue and run 'handleSmtpCmd' to--- determine the 'Event'. In case of syntax errors,--- 'SyntaxErrorIn' or 'Unrecognized' will be returned.--- Inputs must be terminated with 'crlf'. See 'fixCRLF'.--smtpdFSM :: String -> SmtpdFSM-smtpdFSM str = either-                 (\_ -> return (Unrecognized str))-                 handleSmtpCmd-                 (parse smtpCmd "" str)---- |For those who want to parse the 'SmtpCmd' themselves.--- Calling this function in 'HaveQuit' or 'HaveData' will--- fail an assertion. If 'assert' is disabled, it will--- return respectively 'Shutdown' and 'StartData' again.--handleSmtpCmd :: SmtpCmd -> SmtpdFSM-handleSmtpCmd cmd = get >>= \st -> match st cmd-  where-  match :: SessionState -> SmtpCmd -> SmtpdFSM-  match HaveQuit     _       = assert False (event Shutdown)-  match HaveData     _       = assert False (trans (HaveData, StartData))-  match    _  (WrongArg c _) = event (SyntaxErrorIn c)-  match    _        Quit     = trans (HaveQuit, Shutdown)-  match    _        Noop     = event SayOK-  match    _        Turn     = event NotImplemened--  match    _      (Send _)   = event NotImplemened-  match    _      (Soml _)   = event NotImplemened-  match    _      (Saml _)   = event NotImplemened-  match    _      (Vrfy _)   = event NotImplemened-  match    _      (Expn _)   = event NotImplemened-  match    _      (Help x)   = event (SeeksHelp x)--  match Unknown    Rset      = event SayOK-  match HaveHelo   Rset      = event SayOK-  match    _       Rset      = trans (HaveHelo, ResetState)--  match Unknown   (Helo x)   = trans (HaveHelo, SayHelo x)-  match    _      (Helo x)   = trans (HaveHelo, SayHeloAgain x)-  match Unknown   (Ehlo x)   = trans (HaveHelo, SayEhlo x)-  match    _      (Ehlo x)   = trans (HaveHelo, SayEhloAgain x)--  match Unknown (MailFrom _) = event NeedHeloFirst-  match    _    (MailFrom x) = trans (HaveMailFrom, SetMailFrom x)--  match Unknown  (RcptTo _)  = event NeedHeloFirst-  match HaveHelo (RcptTo _)  = event NeedMailFromFirst-  match    _     (RcptTo x)  = trans (HaveRcptTo, AddRcptTo x)--  match Unknown       Data   = event NeedHeloFirst-  match HaveHelo      Data   = event NeedMailFromFirst-  match HaveMailFrom  Data   = event NeedRcptToFirst-  match HaveRcptTo    Data   = trans (HaveData, StartData)--  event :: Event -> SmtpdFSM-  event = return--  trans :: (SessionState, Event) -> SmtpdFSM-  trans (st,e) = put st >> event e---------------------------------------------------------------------------- * Data Types for SMTP Commands--------------------------------------------------------------------------- |The 'smtpCmd' parser will create this data type from a--- string. Note that /all/ command parsers expect their--- input to be terminated with 'crlf'.--data SmtpCmd-  = Helo String-  | Ehlo String-  | MailFrom Mailbox            -- ^ Might be 'nullPath'.-  | RcptTo Mailbox              -- ^ Might be 'postmaster'.-  | Data-  | Rset-  | Send Mailbox-  | Soml Mailbox-  | Saml Mailbox-  | Vrfy String-  | Expn String-  | Help String                 -- ^ Might be @[]@.-  | Noop                        -- ^ Optional argument ignored.-  | Quit-  | Turn-  | WrongArg String ParseError-      -- ^ When a valid command has been recognized, but the-      -- argument parser fails, then this type will be-      -- returned. The 'String' contains the name of the-      -- command (in all upper-case) and the 'ParseError'-      -- is, obviously, the error description.--instance Show SmtpCmd where-  show (Helo str)    = "HELO " ++ str-  show (Ehlo str)    = "EHLO " ++ str-  show (MailFrom mbox) = "MAIL FROM:" ++ show mbox-  show (RcptTo mbox) = "RCPT TO:" ++ show mbox-  show (Data)        = "DATA"-  show (Rset)        = "RSET"-  show (Send mbox)   = "SEND " ++ show mbox-  show (Soml mbox)   = "SOML " ++ show mbox-  show (Saml mbox)   = "SAML " ++ show mbox-  show (Vrfy str)    = "VRFY " ++ str-  show (Expn str)    = "EXPN " ++ str-  show (Noop)        = "NOOP"-  show (Quit)        = "QUIT"-  show (Turn)        = "TURN"-  show (Help t)-    | null t         = "HELP"-    | otherwise      = "HELP " ++ t-  show (WrongArg str _) =-    "Syntax error in argument of " ++ str ++ "."---- |The most general e-mail address has the form:--- @\<[\@route,...:]user\@domain\>@. This type, too,--- supports 'show' and 'read'. Note that a \"shown\" address--- is /always/ enclosed in angular brackets. When comparing--- two mailboxes for equality, the hostname is case-insensitive.--data Mailbox = Mailbox [String] String String--instance Eq Mailbox where-  lhs == rhs  =  norm lhs == norm rhs-    where-    norm (Mailbox rt lp hp) = (rt, lp, map toLower hp)--instance Show Mailbox where-  show (Mailbox [] [] []) = "<>"-  show (Mailbox [] "postmaster" []) = "<postmaster>"-  show (Mailbox p u d) = "<" ++ route ++ (if null route then [] else ":") ++ mbox ++ ">"-    where-      route = intercalate "," . map ((:) '@') $ p-      mbox  = u ++ "@" ++ d--instance Read Mailbox where-  readsPrec _ = parsec2read (path <|> mailbox)-  readList    = error "reading [Mailbox] is not supported"---- |@nullPath@ @=@ @'Mailbox' [] \"\" \"\" = \"\<\>\"@--nullPath :: Mailbox-nullPath = Mailbox [] [] []---- |@postmaster@ @=@ @'Mailbox' [] \"postmaster\" \"\" = \"\<postmaster\>\"@--postmaster :: Mailbox-postmaster = Mailbox [] "postmaster" []---------------------------------------------------------------------------- * Data Types for SMTP Replies--------------------------------------------------------------------------- |An SMTP reply is a three-digit return code plus some waste of--- bandwidth called \"comments\". This is what the list of strings is--- for; one string per line in the reply. 'show' will append an--- \"@\\r\\n@\" end-of-line marker to each entry in that list, so that--- the resulting string is ready to be sent back to the peer. For--- example:------ >>> show $ Reply (Code Success MailSystem 0) ["worked", "like", "a charm" ]--- "250-worked\r\n250-like\r\n250 a charm\r\n"------ If the message is an empty list @[]@, a default text will be constructed:------ >>> show $ Reply (Code Success MailSystem 0) []--- "250 Success in category MailSystem\r\n"--data SmtpReply = Reply SmtpCode [String]--data SmtpCode = Code SuccessCode Category Int--data SuccessCode-  = Unused0-  | PreliminarySuccess-  | Success-  | IntermediateSuccess-  | TransientFailure-  | PermanentFailure-  deriving (Enum, Bounded, Eq, Ord, Show)--data Category-  = Syntax-  | Information-  | Connection-  | Unspecified3-  | Unspecified4-  | MailSystem-  deriving (Enum, Bounded, Eq, Ord, Show)--instance Show SmtpReply where-  show (Reply c@(Code suc cat _) []) =-    let msg = show suc ++ " in category " ++ show cat-    in-    show $ Reply c [msg]--  show (Reply code msg) =-    let prefixCon = show code ++ "-"-        prefixEnd = show code ++ " "-        fmt p l   = p ++ l ++ "\r\n"-        (x:xs) = reverse msg-        msgCon = map (fmt prefixCon) xs-        msgEnd = fmt prefixEnd x-        msg'   = reverse (msgEnd:msgCon)-    in-    concat msg'--instance Show SmtpCode where-  show (Code suc cat n) =-    assert (n >= 0 && n <= 9) $-      (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n---- |Construct a 'Reply'. Fails 'assert' if invalid numbers--- are given.--reply :: Int -> Int -> Int -> [String] -> SmtpReply-reply suc c n msg =-  assert (suc >= 0 && suc <= 5) $-    assert (c >= 0 && c <= 5)   $-      assert (n >= 0 && n <= 9) $-        Reply (Code (toEnum suc) (toEnum c) n) msg---- |A reply constitutes \"success\" if the status code is--- any of 'PreliminarySuccess', 'Success', or--- 'IntermediateSuccess'.--isSuccess :: SmtpReply -> Bool-isSuccess (Reply (Code PreliminarySuccess _ _) _)  = True-isSuccess (Reply (Code Success _ _) _)             = True-isSuccess (Reply (Code IntermediateSuccess _ _) _) = True-isSuccess _                                        = False---- |A reply constitutes \"failure\" if the status code is--- either 'PermanentFailure' or 'TransientFailure'.--isFailure :: SmtpReply -> Bool-isFailure (Reply (Code PermanentFailure _ _) _) = True-isFailure (Reply (Code TransientFailure _ _) _) = True-isFailure _                                     = False---- |The replies @221@ and @421@ signify 'Shutdown'.--isShutdown :: SmtpReply -> Bool-isShutdown (Reply (Code Success Connection 1) _)          = True-isShutdown (Reply (Code TransientFailure Connection 1) _) = True-isShutdown _                                              = False--------------------------------------------------------------------------- * Command Parsers--------------------------------------------------------------------------- |The SMTP parsers defined here correspond to the commands--- specified in RFC2821, so I won't document them--- individually.--type SmtpParser st = CharParser st SmtpCmd---- |This parser recognizes any of the SMTP commands defined--- below. Note that /all/ command parsers expect their input--- to be terminated with 'crlf'.--smtpCmd :: SmtpParser st-smtpCmd = choice-          [ smtpData, rset, noop, quit, turn-          , helo, mail, rcpt, send, soml, saml-          , vrfy, expn, help, ehlo-          ]---- |The parser name \"data\" was taken.-smtpData :: SmtpParser st-rset, quit, turn, helo, ehlo, mail :: SmtpParser st-rcpt, send, soml, saml, vrfy, expn :: SmtpParser st-help                               :: SmtpParser st---- |May have an optional 'word' argument, but it is ignored.-noop :: SmtpParser st--smtpData = mkCmd0 "DATA" Data-rset = mkCmd0 "RSET" Rset-quit = mkCmd0 "QUIT" Quit-turn = mkCmd0 "TURN" Turn-helo = mkCmd1 "HELO" Helo     domain-ehlo = mkCmd1 "EHLO" Ehlo     domain-mail = mkCmd1 "MAIL" MailFrom from_path-rcpt = mkCmd1 "RCPT" RcptTo   to_path-send = mkCmd1 "SEND" Send     from_path-soml = mkCmd1 "SOML" Soml     from_path-saml = mkCmd1 "SAML" Saml     from_path-vrfy = mkCmd1 "VRFY" Vrfy     word-expn = mkCmd1 "EXPN" Expn     word--help = try (mkCmd0 "HELP" (Help [])) <|>-       mkCmd1 "HELP" Help (option [] word)--noop = try (mkCmd0 "NOOP" Noop) <|>-       mkCmd1 "NOOP" (const Noop) (option [] word)---------------------------------------------------------------------------- * Argument Parsers-------------------------------------------------------------------------from_path :: CharParser st Mailbox-from_path = do-  caseString "from:"-  (try (string "<>" >> return nullPath) <|> path)-                                <?> "from-path"--to_path :: CharParser st Mailbox-to_path = do-  caseString "to:"-  (try (caseString "<postmaster>" >> return postmaster)-     <|> path)                  <?> "to-path"--path :: CharParser st Mailbox-path = between (char '<') (char '>') (p <?> "path")-  where-  p = do-    r1 <- option [] (a_d_l >>= \r -> char ':' >> return r)-    (Mailbox _ l d) <- mailbox-    return (Mailbox r1 l d)--mailbox :: CharParser st Mailbox-mailbox = p <?> "mailbox"-  where-  p = do-    r1 <- local_part-    _ <- char '@'-    r2 <- domain-    return (Mailbox [] r1 r2)--local_part :: CharParser st String-local_part = (dot_string <|> quoted_string) <?> "local-part"--domain :: CharParser st String-domain = choice-         [ tokenList subdomain '.'  <?> "domain"-         , address_literal          <?> "address literal"-         ]--a_d_l :: CharParser st [String]-a_d_l = sepBy1 at_domain (char ',') <?> "route-list"--at_domain :: CharParser st String-at_domain = (char '@' >> domain) <?> "at-domain"---- |/TODO/: Add IPv6 address and general literals-address_literal :: CharParser st String-address_literal = ipv4_literal  <?> "IPv4 address literal"--ipv4_literal :: CharParser st String-ipv4_literal = do-  rs <- between (char '[') (char ']') ipv4addr-  return ('[': reverse (']': reverse rs))--ipv4addr :: CharParser st String-ipv4addr = p <?> "IPv4 address literal"-  where-  p = do-    r1 <- snum-    r2 <- char '.' >> snum-    r3 <- char '.' >> snum-    r4 <- char '.' >> snum-    return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4)--subdomain :: CharParser st String-subdomain = p <?> "domain name"-  where-  p = do-    r <- many1 (alpha <|> digit <|> char '-')-    if last r == '-'-        then fail "subdomain must not end with hyphen"-        else return r--dot_string :: CharParser st String-dot_string = tokenList atom '.' <?> "dot_string"--atom :: CharParser a String-atom = many1 atext              <?> "atom"-  where-  atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"--snum :: CharParser st String-snum = do-  r <- manyNtoM 1 3 digit-  if (read r :: Int) > 255-     then fail "IP address parts must be 0 <= x <= 255"-     else return r--number :: CharParser st String-number = many1 digit---- |This is a useful addition: The parser accepts an 'atom'--- or a 'quoted_string'.--word :: CharParser st String-word = (atom <|> fmap show quoted_string)-       <?> "word or quoted-string"---------------------------------------------------------------------------- * Helper Functions--------------------------------------------------------------------------- |Make the string 'crlf' terminated no matter what.--- \'@\\n@\' is expanded, otherwise 'crlf' is appended. Note--- that if the string was terminated incorrectly before, it--- still is. This function is useful when reading input with--- 'System.IO.hGetLine' which removes the end-of-line--- delimiter.--fixCRLF :: String -> String-fixCRLF ('\r' :'\n':[]) = fixCRLF []-fixCRLF (  x  :'\n':[]) = x : fixCRLF []-fixCRLF (  x  :  xs   ) = x : fixCRLF xs-fixCRLF      [ ]        = "\r\n"---- |Construct a parser for a command without arguments.--- Expects 'crlf'!--mkCmd0 :: String -> a -> CharParser st a-mkCmd0 str cons = (do-  try (caseString str)-  _ <- skipMany wsp >> crlf-  return cons)                          <?> str---- |Construct a parser for a command with an argument, which--- the given parser will handle. The result of the argument--- parser will be applied to the type constructor before it--- is returned. Expects 'crlf'!--mkCmd1 :: String -> (a -> SmtpCmd) -> CharParser st a-       -> CharParser st SmtpCmd-mkCmd1 str cons p = do-  try (caseString str)-  _ <- wsp-  input <- getInput-  st <- getState-  let eol = skipMany wsp >> crlf-      p'  = between (many wsp) eol p <?> str-      r   = runParser p' st "" input-  case r of-    Left e  -> return (WrongArg str e)-    Right a -> return (cons a)---- @tokenList p '.'@ will parse a token of the form--- \"@p.p@\", or \"@p.p.p@\", and so on. Used in 'domain'--- and 'dot_string', for example.--tokenList :: CharParser st String -> Char-          -> CharParser st String-tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c))

@@ -1,1402 +0,0 @@-{- |-   Module      :  Text.ParserCombinators.Parsec.Rfc2822-   Copyright   :  (c) 2013 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>.--}--module Text.ParserCombinators.Parsec.Rfc2822 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.Rfc2234 hiding ( quoted_pair, quoted_string )---- 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"

@@ -1,22 +0,0 @@-{--   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/Rfc2234.hs"-       , "Text/ParserCombinators/Parsec/Rfc2821.hs"-       , "Text/ParserCombinators/Parsec/Rfc2822.hs"-       ]

@@ -1,21 +0,0 @@-module Main (main) where--import Text.ParserCombinators.Parsec ( parse )-import Text.ParserCombinators.Parsec.Rfc2822---- Read an Internet message from standard input, parse it,--- and return the result.--main :: IO ()-main = do-  input <- getContents-  print $ parse message "<stdin>" (fixEol input)-  return ()---- Make sure all lines are terminated by CRLF.--fixEol :: String -> String-fixEol ('\r':'\n':xs)   = '\r' : '\n' : fixEol xs-fixEol ('\n':xs)        = '\r' : '\n' : fixEol xs-fixEol (x:xs)           = x : fixEol xs-fixEol []               = []

@@ -1,20 +0,0 @@-X-From-Line: rtMj@example.org  Tue Jun 22 15:11:15 2004-Return-Path: <rtMj@example.org>-Received: from example.org ([127.0.0.1])-	by peti.cryp.to with SMTP id i5MDBAW8014197 for <simons@cryp.to>;-	Tue, 22 Jun 2004 15:11:12 +0200-Received: (qmail 076 invoked from network); Tue, 22 Jun 2004 09:09:16 -0400-Message-ID: <cfbc01c4585a$b88ef7c1$b1f1cdaf@RShrkKx>-From: "virtual shop" <rtMj@example.org>-To: simons@cryp.to-Subject: PROTECT your Computer from tampering ! 315683-Date: Tue, 22 Jun 2004 09:09:16 -0400-Mime-Version: 1.0-Content-Type: multipart/alternative;-	boundary="----=_NextPart_013_7A25_1AC67A25.1AC67A25"-X-Priority: 3-X-MSMail-Priority: Normal-X-Mailer: Microsoft Outlook Express 6.00.2800.1409-X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2800.1409--This is a spam message.

@@ -1,12 +0,0 @@-module Main (main) where--import Text.ParserCombinators.Parsec ( parse )-import Text.ParserCombinators.Parsec.Rfc2821---- Read an SMTP command from standard input, parse it,--- return the result, and loop until EOF.--main :: IO ()-main = do-  input <- getContents-  mapM_ (print . parse smtpCmd "") [ l ++ "\r\n" | l <- lines input ]

@@ -1,7 +0,0 @@-helo smtp.example.org-mail from:<jane.doe@example.org>-rcpt to:<joe.doe@example.net>-RCPT to:<@example.org,@example.com:joe.doe@example.net>-VrFy localuser-data-quit

@@ -1,40 +1,72 @@-Name:                   hsemail-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>-Maintainer:             Peter Simons <simons@cryp.to>-Homepage:               http://github.com/peti/hsemail-Category:               Parsing-Synopsis:               Internet Message Parsers-Description:            Parsers for the syntax defined in RFC2821 and 2822-Cabal-Version:          >= 1.8-Build-Type:             Simple-Tested-With:            GHC >= 6.12.3 && <= 7.6.3+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack -Extra-Source-Files:     example/message-test.hs-                        example/message-test.input-                        example/smtp-test.hs-                        example/smtp-test.input+name:                   hsemail+version:                2+synopsis:               Parsec parsers for the RFC2822 Internet Message format+description:            Parsec parsers for the Internet Message format defined in RFC 2821 and 2822.+category:               Parsing+stability:              stable+homepage:               https://github.com/peti/hsemail#readme+bug-reports:            https://github.com/peti/hsemail/issues+author:                 Peter Simons,+                        Ali Abrar,+                        Gero Kriependorf,+                        Marty Pauley+maintainer:             Peter Simons <simons@cryp.to>+license:                BSD3+license-file:           LICENSE+tested-with:            GHC > 7.8 && < 8.1+build-type:             Simple+cabal-version:          >= 1.10 -Source-Repository head-  Type:                 git-  Location:             git://github.com/peti/hsemail.git+source-repository head+  type: git+  location: https://github.com/peti/hsemail -Library-  Build-Depends:        base >= 3 && < 5, mtl, parsec, old-time-  Exposed-Modules:      Text.ParserCombinators.Parsec.Rfc2234-                        Text.ParserCombinators.Parsec.Rfc2821-                        Text.ParserCombinators.Parsec.Rfc2822-  Ghc-Options:          -Wall+library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >= 3 && < 5+    , old-time+    , parsec >= 3.1+    , mtl+  exposed-modules:+      Text.Parsec.Rfc2234+      Text.Parsec.Rfc2821+      Text.Parsec.Rfc2822+  other-modules:+      Paths_hsemail+  default-language: Haskell2010 -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: doctest.hs+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base >= 3 && < 5+    , old-time+    , parsec >= 3.1+    , mtl+    , doctest+  default-language: Haskell2010 -Test-Suite doctest-hsemail-  type:                 exitcode-stdio-1.0-  main-is:              doc-test.hs-  build-depends:        base, doctest+test-suite test-hsemail+  type: exitcode-stdio-1.0+  main-is: spec.hs+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base >= 3 && < 5+    , old-time+    , parsec >= 3.1+    , mtl+    , hspec+    , hsemail+  default-language: Haskell2010

@@ -1,308 +0,0 @@-{--   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.Rfc2822--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>,( \r\n bla),,jane@\r\n example.net \r\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\r\n" `shouldReturn` " foo"--  describe "Rfc2822.comment" $-    it "doesn't consume leading whitespace" $-      parseTest comments "Comments: foo\r\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\\\r\n blah\"@example.com" -- Folding white space can't appear within a quoted pair-      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.\r\n\r\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 " \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n (  x \r\n ) \r\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.\r\n Folding.\r\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\r\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\r\n the (\"wonderful\" (!)) world\r\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.(\r\n middle\r\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. \r\n \r\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.\r\n \r\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>\r\n" `shouldReturn` "<joe@example.de>"-      parseTest return_path "Return-Path: <>\r\n" `shouldReturn` "<>"-    it "loses the route-part of an obsolete routing address" $-      parseTest return_path "Return-Path: <@example1.org,@example2.org:joe@example.org>\r\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"

@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+   Module      :  Text.Parsec.Rfc2234+   Copyright   :  (c) 2013 Peter Simons+   License     :  BSD3++   Maintainer  :  simons@cryp.to+   Stability   :  provisional+   Portability :  portable++   This module provides parsers for the grammar defined in+   RFC2234, \"Augmented BNF for Syntax Specifications:+   ABNF\", <http://www.faqs.org/rfcs/rfc2234.html>. The+   terminal called @char@ in the RFC is called 'character'+   here to avoid conflicts with Parsec's 'char' function.+ -}++module Text.Parsec.Rfc2234 where++import Control.Monad ( liftM2, replicateM )+import Data.Char ( toUpper, chr, ord )+import Text.Parsec hiding (crlf)+import qualified Text.Parsec.String as PS++-- Customize hlint ...+{-# ANN module "HLint: ignore Use camelCase" #-}++----------------------------------------------------------------------+-- * Parser Combinators+----------------------------------------------------------------------++-- |Case-insensitive variant of Parsec's 'char' function.++caseChar        :: Stream s m Char => Char -> ParsecT s u m Char+caseChar c       = satisfy (\x -> toUpper x == toUpper c)++-- |Case-insensitive variant of Parsec's 'string' function.++caseString      :: Stream s m Char => String -> ParsecT s u m ()+caseString cs    = mapM_ caseChar cs <?> cs++-- |Match a parser at least @n@ times.++-- manyN           :: Int -> GenParser a b c -> GenParser a b [c]+manyN :: Int -> ParsecT s u m a -> ParsecT s u m [a]+manyN n p+    | n <= 0     = return []+    | otherwise  = liftM2 (++) (replicateM n p) (many p)++-- |Match a parser at least @n@ times, but no more than @m@ times.++manyNtoM        :: Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]+manyNtoM n m p+    | n < 0      = return []+    | n > m      = return []+    | n == m     = replicateM n p+    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ replicateM x p) (reverse [1..m]))+    | otherwise  = liftM2 (++) (replicateM n p) (manyNtoM 0 (m-n) p)++-- |Helper function to generate 'Parser'-based instances for+-- the 'Read' class.++parsec2read :: PS.Parser a -> String -> [(a, String)]+parsec2read f x  = either (error . show) id (parse f' "" x)+  where+  f' = do { a <- f; res <- getInput; return [(a,res)] }+++----------------------------------------------------------------------+-- * Primitive Parsers+----------------------------------------------------------------------++-- |Match any character of the alphabet.++alpha           :: Stream s m Char => ParsecT s u m Char+alpha            = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z']))+                   <?> "alphabetic character"++-- |Match either \"1\" or \"0\".++bit             :: Stream s m Char => ParsecT s u m Char+bit              = oneOf "01"   <?> "bit ('0' or '1')"++-- |Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is).++character       :: Stream s m Char => ParsecT s u m Char+character        = satisfy (\c -> (c >= chr 1) && (c <= chr 127))+                   <?> "7-bit character excluding NUL"++-- |Match the carriage return character @\\r@.++cr              :: Stream s m Char => ParsecT s u m Char+cr               = char '\r'    <?> "carriage return"++-- |Match returns the linefeed character @\\n@.++lf              :: Stream s m Char => ParsecT s u m Char+lf               = char '\n'    <?> "linefeed"++-- |Match the Internet newline @\\r\\n@.++crlf            :: Stream s m Char => ParsecT s u m String+crlf             = do c <- cr+                      l <- lf+                      return [c,l]+                   <?> "carriage return followed by linefeed"++-- |Match any US-ASCII control character. That is+-- any character with a decimal value in the range of [0..31,127].++ctl             :: Stream s m Char => ParsecT s u m Char+ctl              = satisfy (\c -> ord c `elem` ([0..31] ++ [127]))+                   <?> "control character"++-- |Match the double quote character \"@\"@\".++dquote          :: Stream s m Char => ParsecT s u m Char+dquote           = char (chr 34)    <?> "double quote"++-- |Match any character that is valid in a hexadecimal number;+-- [\'0\'..\'9\'] and [\'A\'..\'F\',\'a\'..\'f\'] that is.++hexdig          :: Stream s m Char => ParsecT s u m Char+hexdig           = hexDigit    <?> "hexadecimal digit"++-- |Match the tab (\"@\\t@\") character.++htab            :: Stream s m Char => ParsecT s u m Char+htab             = char '\t'    <?> "horizontal tab"++-- |Match \"linear white-space\". That is any number of consecutive+-- 'wsp', optionally followed by a 'crlf' and (at least) one more+-- 'wsp'.++lwsp            :: Stream s m Char => ParsecT s u m String+lwsp             = do r <- choice+                           [ many1 wsp+                           , try (liftM2 (++) crlf (many1 wsp))+                           ]+                      rs <- option [] lwsp+                      return (r ++ rs)+                   <?> "linear white-space"++-- |Match /any/ character.+octet           :: Stream s m Char => ParsecT s u m Char+octet            = anyChar    <?> "any 8-bit character"++-- |Match the space.++sp              :: Stream s m Char => ParsecT s u m Char+sp               = char ' '    <?> "space"++-- |Match any printable ASCII character. (The \"v\" stands for+-- \"visible\".) That is any character in the decimal range of+-- [33..126].++vchar           :: Stream s m Char => ParsecT s u m Char+vchar            = satisfy (\c -> (c >= chr 33) && (c <= chr 126))+                   <?> "printable character"++-- |Match either 'sp' or 'htab'.++wsp             :: Stream s m Char => ParsecT s u m Char+wsp              = sp <|> htab    <?> "white-space"+++-- ** Useful additions++-- |Match a \"quoted pair\". Any characters (excluding CR and+-- LF) may be quoted.++quoted_pair     :: Stream s m Char => ParsecT s u m 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.++quoted_string   :: Stream s m Char => ParsecT s u m String+quoted_string    = do _ <- dquote+                      r <- many qcont+                      _ <- dquote+                      return ("\"" ++ concat r ++ "\"")+                   <?> "quoted string"+  where+  qtext = noneOf "\\\"\r\n"+  qcont = many1 qtext <|> quoted_pair

@@ -0,0 +1,521 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+   Module      :  Text.Parsec.Rfc2821+   Copyright   :  (c) 2013 Peter Simons+   License     :  BSD3++   Maintainer  :  simons@cryp.to+   Stability   :  provisional+   Portability :  portable++   This module exports parser combinators for the grammar+   described in RFC2821, \"Simple Mail Transfer Protocol\",+   <http://www.faqs.org/rfcs/rfc2821.html>.+-}++module Text.Parsec.Rfc2821 where++import Text.Parsec.Rfc2234++import Control.Exception ( assert )+import Control.Monad.State+import Data.Char ( toLower )+import Data.List ( intercalate )+import Text.Parsec hiding (crlf)++-- Customize hlint ...+{-# ANN module "HLint: ignore Use camelCase" #-}++----------------------------------------------------------------------+-- * ESMTP State Machine+----------------------------------------------------------------------++data SessionState+  = Unknown+  | HaveHelo+  | HaveMailFrom+  | HaveRcptTo+  | HaveData+  | HaveQuit+  deriving (Enum, Bounded, Eq, Ord, Show)++data Event+  = Greeting                    -- ^ reserved for the user+  | SayHelo       String+  | SayHeloAgain  String+  | SayEhlo       String+  | SayEhloAgain  String+  | SetMailFrom   Mailbox+  | AddRcptTo     Mailbox+  | StartData+  | Deliver                     -- ^ reserved for the user+  | NeedHeloFirst+  | NeedMailFromFirst+  | NeedRcptToFirst+  | NotImplemened+        -- ^ 'Turn', 'Send', 'Soml', 'Saml', 'Vrfy', and 'Expn'.+  | ResetState+  | SayOK+        -- ^ Triggered in case of 'Noop' or when 'Rset' is+        -- used before we even have a state.+  | SeeksHelp     String+        -- ^ The parameter may be @[]@.+  | Shutdown+  | SyntaxErrorIn String+  | Unrecognized  String+  deriving (Eq, Show)++type SmtpdFSM = Control.Monad.State.State SessionState Event++-- |Parse a line of SMTP dialogue and run 'handleSmtpCmd' to+-- determine the 'Event'. In case of syntax errors,+-- 'SyntaxErrorIn' or 'Unrecognized' will be returned.+-- Inputs must be terminated with 'crlf'. See 'fixCRLF'.++smtpdFSM :: String -> SmtpdFSM+smtpdFSM str = either+                 (\_ -> return (Unrecognized str))+                 handleSmtpCmd+                 (parse smtpCmd "" str)++-- |For those who want to parse the 'SmtpCmd' themselves.+-- Calling this function in 'HaveQuit' or 'HaveData' will+-- fail an assertion. If 'assert' is disabled, it will+-- return respectively 'Shutdown' and 'StartData' again.++handleSmtpCmd :: SmtpCmd -> SmtpdFSM+handleSmtpCmd cmd = get >>= \st -> match st cmd+  where+  match :: SessionState -> SmtpCmd -> SmtpdFSM+  match HaveQuit     _       = assert False (event Shutdown)+  match HaveData     _       = assert False (trans (HaveData, StartData))+  match    _  (WrongArg c _) = event (SyntaxErrorIn c)+  match    _        Quit     = trans (HaveQuit, Shutdown)+  match    _        Noop     = event SayOK+  match    _        Turn     = event NotImplemened++  match    _      (Send _)   = event NotImplemened+  match    _      (Soml _)   = event NotImplemened+  match    _      (Saml _)   = event NotImplemened+  match    _      (Vrfy _)   = event NotImplemened+  match    _      (Expn _)   = event NotImplemened+  match    _      (Help x)   = event (SeeksHelp x)++  match Unknown    Rset      = event SayOK+  match HaveHelo   Rset      = event SayOK+  match    _       Rset      = trans (HaveHelo, ResetState)++  match Unknown   (Helo x)   = trans (HaveHelo, SayHelo x)+  match    _      (Helo x)   = trans (HaveHelo, SayHeloAgain x)+  match Unknown   (Ehlo x)   = trans (HaveHelo, SayEhlo x)+  match    _      (Ehlo x)   = trans (HaveHelo, SayEhloAgain x)++  match Unknown (MailFrom _) = event NeedHeloFirst+  match    _    (MailFrom x) = trans (HaveMailFrom, SetMailFrom x)++  match Unknown  (RcptTo _)  = event NeedHeloFirst+  match HaveHelo (RcptTo _)  = event NeedMailFromFirst+  match    _     (RcptTo x)  = trans (HaveRcptTo, AddRcptTo x)++  match Unknown       Data   = event NeedHeloFirst+  match HaveHelo      Data   = event NeedMailFromFirst+  match HaveMailFrom  Data   = event NeedRcptToFirst+  match HaveRcptTo    Data   = trans (HaveData, StartData)++  event :: Event -> SmtpdFSM+  event = return++  trans :: (SessionState, Event) -> SmtpdFSM+  trans (st,e) = put st >> event e+++----------------------------------------------------------------------+-- * Data Types for SMTP Commands+----------------------------------------------------------------------++-- |The 'smtpCmd' parser will create this data type from a+-- string. Note that /all/ command parsers expect their+-- input to be terminated with 'crlf'.++data SmtpCmd+  = Helo String+  | Ehlo String+  | MailFrom Mailbox            -- ^ Might be 'nullPath'.+  | RcptTo Mailbox              -- ^ Might be 'postmaster'.+  | Data+  | Rset+  | Send Mailbox+  | Soml Mailbox+  | Saml Mailbox+  | Vrfy String+  | Expn String+  | Help String                 -- ^ Might be @[]@.+  | Noop                        -- ^ Optional argument ignored.+  | Quit+  | Turn+  | WrongArg String ParseError+      -- ^ When a valid command has been recognized, but the+      -- argument parser fails, then this type will be+      -- returned. The 'String' contains the name of the+      -- command (in all upper-case) and the 'ParseError'+      -- is, obviously, the error description.++instance Show SmtpCmd where+  show (Helo str)       = "HELO " ++ str+  show (Ehlo str)       = "EHLO " ++ str+  show (MailFrom mbox)  = "MAIL FROM:" ++ show mbox+  show (RcptTo mbox)    = "RCPT TO:" ++ show mbox+  show Data             = "DATA"+  show Rset             = "RSET"+  show (Send mbox)      = "SEND " ++ show mbox+  show (Soml mbox)      = "SOML " ++ show mbox+  show (Saml mbox)      = "SAML " ++ show mbox+  show (Vrfy str)       = "VRFY " ++ str+  show (Expn str)       = "EXPN " ++ str+  show Noop             = "NOOP"+  show Quit             = "QUIT"+  show Turn             = "TURN"+  show (Help t)+    | null t            = "HELP"+    | otherwise         = "HELP " ++ t+  show (WrongArg str _) = "Syntax error in argument of " ++ str ++ "."++-- |The most general e-mail address has the form:+-- @\<[\@route,...:]user\@domain\>@. This type, too,+-- supports 'show' and 'read'. Note that a \"shown\" address+-- is /always/ enclosed in angular brackets. When comparing+-- two mailboxes for equality, the hostname is case-insensitive.++data Mailbox = Mailbox [String] String String++instance Eq Mailbox where+  lhs == rhs  =  norm lhs == norm rhs+    where+    norm (Mailbox rt lp hp) = (rt, lp, map toLower hp)++instance Show Mailbox where+  show (Mailbox [] [] []) = "<>"+  show (Mailbox [] "postmaster" []) = "<postmaster>"+  show (Mailbox p u d) = "<" ++ route ++ (if null route then [] else ":") ++ mbox ++ ">"+    where+      route = intercalate "," . map ((:) '@') $ p+      mbox  = u ++ "@" ++ d++instance Read Mailbox where+  readsPrec _ = parsec2read (path <|> mailbox)+  readList    = error "reading [Mailbox] is not supported"++-- |@nullPath@ @=@ @'Mailbox' [] \"\" \"\" = \"\<\>\"@++nullPath :: Mailbox+nullPath = Mailbox [] [] []++-- |@postmaster@ @=@ @'Mailbox' [] \"postmaster\" \"\" = \"\<postmaster\>\"@++postmaster :: Mailbox+postmaster = Mailbox [] "postmaster" []+++----------------------------------------------------------------------+-- * Data Types for SMTP Replies+----------------------------------------------------------------------++-- |An SMTP reply is a three-digit return code plus some waste of+-- bandwidth called \"comments\". This is what the list of strings is+-- for; one string per line in the reply. 'show' will append an+-- \"@\\r\\n@\" end-of-line marker to each entry in that list, so that+-- the resulting string is ready to be sent back to the peer. For+-- example:+--+-- >>> show $ Reply (Code Success MailSystem 0) ["worked", "like", "a charm" ]+-- "250-worked\r\n250-like\r\n250 a charm\r\n"+--+-- If the message is an empty list @[]@, a default text will be constructed:+--+-- >>> show $ Reply (Code Success MailSystem 0) []+-- "250 Success in category MailSystem\r\n"++data SmtpReply = Reply SmtpCode [String]++data SmtpCode = Code SuccessCode Category Int++data SuccessCode+  = Unused0+  | PreliminarySuccess+  | Success+  | IntermediateSuccess+  | TransientFailure+  | PermanentFailure+  deriving (Enum, Bounded, Eq, Ord, Show)++data Category+  = Syntax+  | Information+  | Connection+  | Unspecified3+  | Unspecified4+  | MailSystem+  deriving (Enum, Bounded, Eq, Ord, Show)++instance Show SmtpReply where+  show (Reply c@(Code suc cat _) []) =+    let msg = show suc ++ " in category " ++ show cat+    in+    show $ Reply c [msg]++  show (Reply code msg) =+    let prefixCon = show code ++ "-"+        prefixEnd = show code ++ " "+        fmt p l   = p ++ l ++ "\r\n"+        (x:xs) = reverse msg+        msgCon = map (fmt prefixCon) xs+        msgEnd = fmt prefixEnd x+        msg'   = reverse (msgEnd:msgCon)+    in+    concat msg'++instance Show SmtpCode where+  show (Code suc cat n) =+    assert (n >= 0 && n <= 9) $+      (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n++-- |Construct a 'Reply'. Fails 'assert' if invalid numbers+-- are given.++reply :: Int -> Int -> Int -> [String] -> SmtpReply+reply suc c n msg =+  assert (suc >= 0 && suc <= 5) $+    assert (c >= 0 && c <= 5)   $+      assert (n >= 0 && n <= 9) $+        Reply (Code (toEnum suc) (toEnum c) n) msg++-- |A reply constitutes \"success\" if the status code is+-- any of 'PreliminarySuccess', 'Success', or+-- 'IntermediateSuccess'.++isSuccess :: SmtpReply -> Bool+isSuccess (Reply (Code PreliminarySuccess _ _) _)  = True+isSuccess (Reply (Code Success _ _) _)             = True+isSuccess (Reply (Code IntermediateSuccess _ _) _) = True+isSuccess _                                        = False++-- |A reply constitutes \"failure\" if the status code is+-- either 'PermanentFailure' or 'TransientFailure'.++isFailure :: SmtpReply -> Bool+isFailure (Reply (Code PermanentFailure _ _) _) = True+isFailure (Reply (Code TransientFailure _ _) _) = True+isFailure _                                     = False++-- |The replies @221@ and @421@ signify 'Shutdown'.++isShutdown :: SmtpReply -> Bool+isShutdown (Reply (Code Success Connection 1) _)          = True+isShutdown (Reply (Code TransientFailure Connection 1) _) = True+isShutdown _                                              = False++----------------------------------------------------------------------+-- * Command Parsers+----------------------------------------------------------------------++-- |The SMTP parsers defined here correspond to the commands+-- specified in RFC2821, so I won't document them+-- individually.++-- type SmtpParser s u m = Stream s m Char => ParsecT s u m SmtpCmd++-- |This parser recognizes any of the SMTP commands defined+-- below. Note that /all/ command parsers expect their input+-- to be terminated with 'crlf'.++smtpCmd :: Stream s m Char => ParsecT s u m SmtpCmd+smtpCmd = choice+          [ smtpData, rset, noop, quit, turn+          , helo, mail, rcpt, send, soml, saml+          , vrfy, expn, help, ehlo+          ]++-- |The parser name \"data\" was taken.+smtpData :: Stream s m Char => ParsecT s u m SmtpCmd+rset, quit, turn, helo, ehlo, mail :: Stream s m Char => ParsecT s u m SmtpCmd+rcpt, send, soml, saml, vrfy, expn :: Stream s m Char => ParsecT s u m SmtpCmd+help                               :: Stream s m Char => ParsecT s u m SmtpCmd++-- |May have an optional 'word' argument, but it is ignored.+noop :: Stream s m Char => ParsecT s u m SmtpCmd++smtpData = mkCmd0 "DATA" Data+rset = mkCmd0 "RSET" Rset+quit = mkCmd0 "QUIT" Quit+turn = mkCmd0 "TURN" Turn+helo = mkCmd1 "HELO" Helo     domain+ehlo = mkCmd1 "EHLO" Ehlo     domain+mail = mkCmd1 "MAIL" MailFrom from_path+rcpt = mkCmd1 "RCPT" RcptTo   to_path+send = mkCmd1 "SEND" Send     from_path+soml = mkCmd1 "SOML" Soml     from_path+saml = mkCmd1 "SAML" Saml     from_path+vrfy = mkCmd1 "VRFY" Vrfy     word+expn = mkCmd1 "EXPN" Expn     word++help = try (mkCmd0 "HELP" (Help [])) <|>+       mkCmd1 "HELP" Help (option [] word)++noop = try (mkCmd0 "NOOP" Noop) <|>+       mkCmd1 "NOOP" (const Noop) (option [] word)+++----------------------------------------------------------------------+-- * Argument Parsers+----------------------------------------------------------------------++from_path :: Stream s m Char => ParsecT s u m Mailbox+from_path = do+  caseString "from:"+  (try (string "<>" >> return nullPath) <|> path)+                                <?> "from-path"++to_path :: Stream s m Char => ParsecT s u m Mailbox+to_path = do+  caseString "to:"+  (try (caseString "<postmaster>" >> return postmaster)+     <|> path)                  <?> "to-path"++path :: Stream s m Char => ParsecT s u m Mailbox+path = between (char '<') (char '>') (p <?> "path")+  where+  p = do+    r1 <- option [] (a_d_l >>= \r -> char ':' >> return r)+    (Mailbox _ l d) <- mailbox+    return (Mailbox r1 l d)++mailbox :: Stream s m Char => ParsecT s u m Mailbox+mailbox = p <?> "mailbox"+  where+  p = do+    r1 <- local_part+    _ <- char '@'+    r2 <- domain+    return (Mailbox [] r1 r2)++local_part :: Stream s m Char => ParsecT s u m String+local_part = (dot_string <|> quoted_string) <?> "local-part"++domain :: Stream s m Char => ParsecT s u m String+domain = choice+         [ tokenList subdomain '.'  <?> "domain"+         , address_literal          <?> "address literal"+         ]++a_d_l :: Stream s m Char => ParsecT s u m [String]+a_d_l = sepBy1 at_domain (char ',') <?> "route-list"++at_domain :: Stream s m Char => ParsecT s u m String+at_domain = (char '@' >> domain) <?> "at-domain"++-- |/TODO/: Add IPv6 address and general literals+address_literal :: Stream s m Char => ParsecT s u m String+address_literal = ipv4_literal  <?> "IPv4 address literal"++ipv4_literal :: Stream s m Char => ParsecT s u m String+ipv4_literal = do+  rs <- between (char '[') (char ']') ipv4addr+  return ('[': reverse (']': reverse rs))++ipv4addr :: Stream s m Char => ParsecT s u m String+ipv4addr = p <?> "IPv4 address literal"+  where+  p = do+    r1 <- snum+    r2 <- char '.' >> snum+    r3 <- char '.' >> snum+    r4 <- char '.' >> snum+    return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4)++subdomain :: Stream s m Char => ParsecT s u m String+subdomain = p <?> "domain name"+  where+  p = do+    r <- many1 (alpha <|> digit <|> char '-')+    if last r == '-'+        then fail "subdomain must not end with hyphen"+        else return r++dot_string :: Stream s m Char => ParsecT s u m String+dot_string = tokenList atom '.' <?> "dot_string"++atom :: Stream s m Char => ParsecT s u m String+atom = many1 atext              <?> "atom"+  where+  atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~"++snum :: Stream s m Char => ParsecT s u m String+snum = do+  r <- manyNtoM 1 3 digit+  if (read r :: Int) > 255+     then fail "IP address parts must be 0 <= x <= 255"+     else return r++number :: Stream s m Char => ParsecT s u m String+number = many1 digit++-- |This is a useful addition: The parser accepts an 'atom'+-- or a 'quoted_string'.++word :: Stream s m Char => ParsecT s u m String+word = (atom <|> fmap show quoted_string)+       <?> "word or quoted-string"+++----------------------------------------------------------------------+-- * Helper Functions+----------------------------------------------------------------------++-- |Make the string 'crlf' terminated no matter what.+-- \'@\\n@\' is expanded, otherwise 'crlf' is appended. Note+-- that if the string was terminated incorrectly before, it+-- still is. This function is useful when reading input with+-- 'System.IO.hGetLine' which removes the end-of-line+-- delimiter.++fixCRLF :: String -> String+fixCRLF ('\r' :'\n':[]) = fixCRLF []+fixCRLF (  x  :'\n':[]) = x : fixCRLF []+fixCRLF (  x  :  xs   ) = x : fixCRLF xs+fixCRLF      [ ]        = "\r\n"++-- |Construct a parser for a command without arguments.+-- Expects 'crlf'!++mkCmd0 :: Stream s m Char => String -> a -> ParsecT s u m a+mkCmd0 str cons = (do+  try (caseString str)+  _ <- skipMany wsp >> crlf+  return cons)                          <?> str++-- |Construct a parser for a command with an argument, which+-- the given parser will handle. The result of the argument+-- parser will be applied to the type constructor before it+-- is returned. Expects 'crlf'!++mkCmd1 :: Stream s m Char => String -> (a -> SmtpCmd) -> ParsecT s u m a+       -> ParsecT s u m SmtpCmd+mkCmd1 str cons p = do+  try (caseString str)+  _ <- wsp+  input <- getInput+  st <- getState+  let eol = skipMany wsp >> crlf+      p'  = between (many wsp) eol p <?> str+  r <- lift $ runParserT p' st "" input+  case r of+    Left e  -> return (WrongArg str e)+    Right a -> return (cons a)++-- @tokenList p '.'@ will parse a token of the form+-- \"@p.p@\", or \"@p.p.p@\", and so on. Used in 'domain'+-- and 'dot_string', for example.++tokenList :: Stream s m Char => ParsecT s u m String -> Char+          -> ParsecT s u m String+tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c))

@@ -0,0 +1,1404 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+   Module      :  Text.Parsec.Rfc2822+   Copyright   :  (c) 2013 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>.+-}++module Text.Parsec.Rfc2822 where++import Text.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string )++import Control.Monad ( replicateM )+import Data.Char ( ord )+import Data.List ( intercalate )+import Data.Maybe ( catMaybes )+import Data.Monoid ( Monoid, mempty )+import System.Time+import Text.Parsec hiding (crlf)++-- 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    :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe a)+maybeOption p   = option Nothing (fmap Just p)++-- |@unfold@ @=@ @between (optional cfws) (optional cfws)@++unfold          :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a+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          :: Stream s m Char => String -> ParsecT s u m a -> ParsecT s u m a+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      :: Stream s m Char => String -> ParsecT s u m a -> ParsecT s u m a+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       :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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     :: Stream s m Char => ParsecT s u m 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             :: Stream s m Char => ParsecT s u m 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           :: Stream s m Char => ParsecT s u m 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         :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m 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           :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m String+atom            = unfold (many1 atext <?> "atom")++-- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'.++dot_atom        :: Stream s m Char => ParsecT s u m String+dot_atom        = unfold (dot_atom_text <?> "dot atom")++-- |Match two or more 'atext's interspersed by dots.++dot_atom_text   :: Stream s m Char => ParsecT s u m 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           :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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   :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m String+word            = unfold (atom <|> quoted_string)     <?> "word"++-- |Match either one or more 'word's or an 'obs_phrase'.++phrase          :: Stream s m Char => ParsecT s u m [String]+phrase          = {- many1 word <?> "phrase" <|> -} obs_phrase++-- |Match any non-whitespace, non-control US-ASCII character except+-- for \"@\\@\" and \"@\"@\".++utext           :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m 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       :: Stream s m Char => ParsecT s u m 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     :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m (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            :: Stream s m Char => ParsecT s u m 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           :: Stream s m Char => ParsecT s u m 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      :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m 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             :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m (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     :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m Int+hour            = do r <- replicateM 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          :: Stream s m Char => ParsecT s u m Int+minute          = do r <- replicateM 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          :: Stream s m Char => ParsecT s u m Int+second          = do r <- replicateM 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            :: Stream s m Char => ParsecT s u m 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         :: Stream s m Char => ParsecT s u m [NameAddr]+address         = try (do { r <- mailbox; return [r] }) <|> group+                  <?> "address"++-- |Parse a 'name_addr' or an 'addr_spec' and return the+-- address.++mailbox         :: Stream s m Char => ParsecT s u m 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       :: Stream s m Char => ParsecT s u m 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      :: Stream s m Char => ParsecT s u m 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           :: Stream s m Char => ParsecT s u m [NameAddr]+group           = do _ <- display_name+                     _ <- char ':'+                     r <- option [] mailbox_list+                     _ <- unfold $ char ';'+                     return r+                  <?> "address group"++-- |Parse and return a 'phrase'.++display_name    :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m [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    :: Stream s m Char => ParsecT s u m [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       :: Stream s m Char => ParsecT s u m 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      :: Stream s m Char => ParsecT s u m 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          :: Stream s m Char => ParsecT s u m 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  :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m String+dcontent        = many1 dtext <|> quoted_pair+                  <?> "domain literal content"++-- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and+-- \"@\\@\".++dtext           :: Stream s m Char => ParsecT s u m 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++-- |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         :: (Monoid s, Stream s m Char) => ParsecT s u m (GenericMessage s)+message         = do f <- fields+                     b <- option mempty (do _ <- crlf; body)+                     return (Message f b)++-- |A message body is just an unstructured sequence of characters.++body            :: (Monoid s, Monad m) => ParsecT s u m s+body            = do v <- getInput+                     setInput mempty+                     return v++-- * 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          :: Stream s m Char => ParsecT s u m [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       :: Stream s m Char => ParsecT s u m 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            :: Stream s m Char => ParsecT s u m [NameAddr]+from            = header "From" mailbox_list++-- |Parse a \"@Sender:@\" header line and return the 'mailbox' address+-- contained in it.++sender          :: Stream s m Char => ParsecT s u m NameAddr+sender          = header "Sender" mailbox++-- |Parse a \"@Reply-To:@\" header line and return the 'address_list'+-- address(es) contained in it.++reply_to        :: Stream s m Char => ParsecT s u m [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              :: Stream s m Char => ParsecT s u m [NameAddr]+to              = header "To" address_list++-- |Parse a \"@Cc:@\" header line and return the 'address_list'+-- address(es) contained in it.++cc              :: Stream s m Char => ParsecT s u m [NameAddr]+cc              = header "Cc" address_list++-- |Parse a \"@Bcc:@\" header line and return the 'address_list'+-- address(es) contained in it.++bcc             :: Stream s m Char => ParsecT s u m [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      :: Stream s m Char => ParsecT s u m 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     :: Stream s m Char => ParsecT s u m [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      :: Stream s m Char => ParsecT s u m [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          :: Stream s m Char => ParsecT s u m 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         :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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   :: Stream s m Char => ParsecT s u m 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 :: Stream s m Char => ParsecT s u m 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         :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m [[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     :: Stream s m Char => ParsecT s u m 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     :: Stream s m Char => ParsecT s u m [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   :: Stream s m Char => ParsecT s u m NameAddr+resent_sender   = header "Resent-Sender" mailbox+++-- |Parse a \"@Resent-To:@\" header line and return the 'mailbox'+-- address contained in it.++resent_to       :: Stream s m Char => ParsecT s u m [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       :: Stream s m Char => ParsecT s u m [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      :: Stream s m Char => ParsecT s u m [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   :: Stream s m Char => ParsecT s u m String+resent_msg_id   = header "Resent-Message-ID" msg_id+++-- ** Trace fields (section 3.6.7)++return_path     :: Stream s m Char => ParsecT s u m String+return_path     = header "Return-Path" path++path            :: Stream s m Char => ParsecT s u m String+path            = unfold ( try (do _ <- char '<'+                                   r <- option "" addr_spec+                                   _ <- char '>'+                                   return ("<" ++ r ++ ">")+                               )+                          <|> obs_path+                         )+                  <?> "return path spec"++received        :: Stream s m Char => ParsecT s u m ([(String,String)], CalendarTime)+received        = header "Received" (do r1 <- name_val_list+                                        _ <- char ';'+                                        r2 <- date_time+                                        return (r1,r2))++name_val_list   :: Stream s m Char => ParsecT s u m [(String,String)]+name_val_list   = do optional cfws+                     many1 name_val_pair+                  <?> "list of name/value pairs"++name_val_pair   :: Stream s m Char => ParsecT s u m (String,String)+name_val_pair   = do r1 <- item_name+                     _ <- cfws+                     r2 <- item_value+                     return (r1,r2)+                  <?> "a name/value pair"++item_name       :: Stream s m Char => ParsecT s u m String+item_name       = do r1 <- alpha+                     r2 <- many $ choice [ char '-', alpha, digit ]+                     return (r1 : r2)+                  <?> "name of a name/value pair"++item_value      :: Stream s m Char => ParsecT s u m 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  :: Stream s m Char => ParsecT s u m (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      :: Stream s m Char => ParsecT s u m String+field_name      = many1 ftext <?> "header line name"++-- |Match and return any ASCII character except for control+-- characters, whitespace, and \"@:@\".++ftext           :: Stream s m Char => ParsecT s u m 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          :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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       :: Stream s m Char => ParsecT s u m String+obs_utext       = obs_text++-- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' -+-- allows dots between tokens.++obs_phrase      :: Stream s m Char => ParsecT s u m [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 :: Stream s m Char => ParsecT s u m [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         :: Stream s m Char => ParsecT s u m 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 :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m 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       :: Stream s m Char => ParsecT s u m Month+obs_month       = between cfws cfws month_name <?> "month name"++-- |Parse a 'day' but allow for the obsolete folding syntax.++obs_day         :: Stream s m Char => ParsecT s u m Int+obs_day         = unfold day_of_month <?> "day"++-- |Parse a 'hour' but allow for the obsolete folding syntax.++obs_hour        :: Stream s m Char => ParsecT s u m Int+obs_hour        = unfold hour <?> "hour"++-- |Parse a 'minute' but allow for the obsolete folding syntax.++obs_minute      :: Stream s m Char => ParsecT s u m Int+obs_minute      = unfold minute <?> "minute"++-- |Parse a 'second' but allow for the obsolete folding syntax.++obs_second      :: Stream s m Char => ParsecT s u m Int+obs_second      = unfold second <?> "second"++-- |Match the obsolete zone names and return the appropriate offset.++obs_zone        :: Stream s m Char => ParsecT s u m 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  :: Stream s m Char => ParsecT s u m 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       :: Stream s m Char => ParsecT s u m [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 :: Stream s m Char => ParsecT s u m [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  :: Stream s m Char => ParsecT s u m 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      :: Stream s m Char => ParsecT s u m 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   :: Stream s m Char => ParsecT s u m [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   :: Stream s m Char => ParsecT s u m [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      :: Stream s m Char => ParsecT s u m [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   :: Stream s m Char => ParsecT s u m 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        :: Stream s m Char => ParsecT s u m [NameAddr]+obs_from        = obs_header "From" mailbox_list++-- |Parse a 'sender' header line but allow for the obsolete+-- folding syntax.++obs_sender      :: Stream s m Char => ParsecT s u m NameAddr+obs_sender      = obs_header "Sender" mailbox++-- |Parse a 'reply_to' header line but allow for the obsolete+-- folding syntax.++obs_reply_to    :: Stream s m Char => ParsecT s u m [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          :: Stream s m Char => ParsecT s u m [NameAddr]+obs_to          = obs_header "To" address_list++-- |Parse a 'cc' header line but allow for the obsolete+-- folding syntax.++obs_cc          :: Stream s m Char => ParsecT s u m [NameAddr]+obs_cc          = obs_header "Cc" address_list++-- |Parse a 'bcc' header line but allow for the obsolete+-- folding syntax.++obs_bcc         :: Stream s m Char => ParsecT s u m [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  :: Stream s m Char => ParsecT s u m 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 :: Stream s m Char => ParsecT s u m [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  :: Stream s m Char => ParsecT s u m [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     :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m 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     :: Stream s m Char => ParsecT s u m String+obs_subject     = obs_header "Subject" unstructured++-- |Parse a 'comments' header line but allow for the obsolete+-- folding syntax.++obs_comments    :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m [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 :: Stream s m Char => ParsecT s u m [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 :: Stream s m Char => ParsecT s u m 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 :: Stream s m Char => ParsecT s u m 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   :: Stream s m Char => ParsecT s u m [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   :: Stream s m Char => ParsecT s u m [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  :: Stream s m Char => ParsecT s u m [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  :: Stream s m Char => ParsecT s u m 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 :: Stream s m Char => ParsecT s u m [NameAddr]+obs_resent_reply = obs_header "Resent-Reply-To" address_list+++-- ** Obsolete trace fields (section 4.5.7)++obs_return      :: Stream s m Char => ParsecT s u m String+obs_return       = obs_header "Return-Path" path++obs_received    :: Stream s m Char => ParsecT s u m [(String, String)]+obs_received     = obs_header "Received" name_val_list++-- |Match 'obs_angle_addr'.++obs_path        :: Stream s m Char => ParsecT s u m 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    :: Stream s m Char => ParsecT s u m (String,String)+obs_optional    = do n <- field_name+                     _ <- many wsp+                     _ <- char ':'+                     b <- unstructured+                     _ <- crlf+                     return (n,b)+                  <?> "optional (unspecified) header line"

@@ -0,0 +1,6 @@+module Main ( main ) where++import Test.DocTest++main :: IO ()+main = doctest [ "-isrc", "src" ]

@@ -0,0 +1,297 @@+module Main ( main ) where++import Test.Hspec+import System.Time ( CalendarTime(..), Month(..), Day(..) )+import Text.Parsec ( parse, eof )+import Text.Parsec.String ( Parser )+import Text.Parsec.Rfc2822++parseTest :: Parser 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 :: Parser String -> String -> Expectation+parseIdemTest p input = parseTest p input `shouldReturn` input++parseFailure :: (Show a) => Parser 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>,( \r\n bla),,jane@\r\n example.net \r\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\r\n" `shouldReturn` " foo"++  describe "Rfc2822.comment" $+    it "doesn't consume leading whitespace" $+      parseTest comments "Comments: foo\r\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\\\r\n blah\"@example.com" -- Folding white space can't appear within a quoted pair+      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.\r\n\r\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 " \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n (  x \r\n ) \r\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.\r\n Folding.\r\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\r\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\r\n the (\"wonderful\" (!)) world\r\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.(\r\n middle\r\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. \r\n \r\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.\r\n \r\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>\r\n" `shouldReturn` "<joe@example.de>"+      parseTest return_path "Return-Path: <>\r\n" `shouldReturn` "<>"+    it "loses the route-part of an obsolete routing address" $+      parseTest return_path "Return-Path: <@example1.org,@example2.org:joe@example.org>\r\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"