hsemail (empty) → 1.0

raw patch · 12 files changed

+2283/−0 lines, 12 filesdep +basedep +mtldep +parsecbuild-type:Customsetup-changed

Dependencies added: base, mtl, parsec

Files

• LICENSE +26/−0
• README +51/−0
• Setup.lhs +8/−0
• Text/ParserCombinators/Parsec/Rfc2234.hs +184/−0
• Text/ParserCombinators/Parsec/Rfc2821.hs +524/−0
• Text/ParserCombinators/Parsec/Rfc2822.hs +1404/−0
• example/message-test.hs +21/−0
• example/message-test.input +20/−0
• example/smtp-test.hs +13/−0
• example/smtp-test.input +7/−0
• hsemail.cabal +22/−0
• prologue.txt +3/−0

@@ -0,0 +1,26 @@+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * The names of its contributors may not be used to endorse or promote+    products derived from this software without specific prior written+    permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain

@@ -0,0 +1,184 @@+{- |+   Module      :  Text.ParserCombinators.Parsec.Rfc2234+   Copyright   :  (c) 2007 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 )++----------------------------------------------------------------------+-- * 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     = do 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)

@@ -0,0 +1,524 @@+{- |+   Module      :  Text.ParserCombinators.Parsec.Rfc2821+   Copyright   :  (c) 2007 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 Text.ParserCombinators.Parsec.Error+import Data.List ( intersperse )+import Data.Char ( toLower )+import Text.ParserCombinators.Parsec.Rfc2234++----------------------------------------------------------------------+-- * 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)+    | 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) = let+    route = concat . (intersperse ",") . (map ((:) '@')) $ p+    mbox  = u ++ "@" ++ d+    in if null route then "<" ++ mbox ++ ">"+                     else "<" ++ route ++ ":" ++ mbox ++ ">"++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.+--+-- Here is an example:+--+-- > *Rfc2821> print $ Reply (Code Success MailSystem 0)+-- >                     ["worked", "like", "a charm" ]+-- > 250-worked+-- > 250-like+-- > 250 a charm+--+-- If the message is @[]@, you'll get a really helpful+-- default text.++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" (\_ -> 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 <|> (quoted_string >>= return . show))+       <?> "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 = do+  xs <- sepBy1 p (char c)+  return (concat (intersperse [c] xs))

@@ -0,0 +1,1404 @@+{- |+   Module      :  Text.ParserCombinators.Parsec.Rfc2822+   Copyright   :  (c) 2007 by Peter Simons+   License     :  BSD3++   Maintainer  :  simons@cryp.to+   Stability   :  provisional+   Portability :  portable++   This module provides parsers for the grammar defined in+   RFC2822, \"Internet Message Format\",+   <http://www.faqs.org/rfcs/rfc2822.html>.++   /Please note:/ The module is a mess. I keep it around as+   a reminder that it needs to be rewritten, mostly.+   Nevertheless, some parsers -- like 'date_time', for+   example -- are genuinely useful.+-}++module Text.ParserCombinators.Parsec.Rfc2822 where++import Text.ParserCombinators.Parsec+import Data.Char ( ord )+import Data.List ( intersperse )+import System.Time+import Text.ParserCombinators.Parsec.Rfc2234+        hiding ( quoted_pair, quoted_string )++-- * Useful parser combinators++-- |@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     = 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   = do r <- sepBy1 (many1 atext) (char '.')+                     return (concat (intersperse "." r))+                  <?> "dot atom content"+++-- ** Quoted strings (section 3.2.5)++-- |Match any non-whitespace, non-control US-ASCII character except+-- for \"@\\@\" and \"@\"@\".++qtext           :: CharParser a Char+qtext           = 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            = 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 <- many (do r1 <- option [] fws+                                    r2 <- utext+                                    return (r1 ++ [r2]))+                     r2 <- option [] fws+                     return (concat r1 ++ 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 will match a 'day_name', optionally wrapped in folding+-- whitespace, or an 'obs_day_of_week' and return it's '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 it's integer+-- value. No range checking is performed.++year            :: CharParser a Int+year            = do y <- manyN 4 digit+                     return (read y :: Int)+                  <?> "year"++-- |This parser will match a 'month_name', optionally wrapped in+-- folding whitespace, or an 'obs_month' and return it's '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"++-- |Match either an 'obs_day', or a one or two digit number and return it.++day             :: CharParser a Int+day             =  try (do { optional fws; r <- manyNtoM 1 2 digit; return (read r :: Int) }) <|> obs_day+                   <?> "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 it's integer+-- value. No range checking is performed.++hour            :: CharParser a Int+hour            = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "hour"++-- |This parser will match a two-digit number and return it's integer+-- value. No range checking is performed.++minute          :: CharParser a Int+minute          = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "minute"++-- |This parser will match a two-digit number and return it's integer+-- value. No range checking takes place.++second          :: CharParser a Int+second          = do r <- count 2 digit+                     return (read r :: Int)+                  <?> "second"++-- |This parser will match a timezone specification of the form+-- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in+-- seconds as an integer. '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)++-- |Parse a single 'mailbox' or an address 'group' and return the+-- address(es).++address         :: CharParser a [String]+address         = try (do { r <- mailbox; return [r] }) <|> group+                  <?> "address"++-- |Parse a 'name_addr' or an 'addr_spec' and return the+-- address.++mailbox         :: CharParser a String+mailbox         = try name_addr <|> addr_spec+                  <?> "mailbox"++-- |Parse an 'angle_addr', optionally prefaced with a 'display_name',+-- and return the address.++name_addr       :: CharParser a String+name_addr       = do optional display_name+                     angle_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;"+--+-- This input comes out as:+--+-- >    Right ["user1@example.org","user2@example.org"]++group           :: CharParser a [String]+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    = 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 [String]+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 [String]+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      = 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          = 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 $ do { 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,127]))+                  <?> "character (excluding '[', ']', and '\\')"+++-- * Overall message syntax (section 3.5)++-- |This data type repesents a parsed Internet Message as defined in+-- this RFC. It consists of an arbitrary number of header lines,+-- represented in the 'Field' data type, and a message body, which may+-- be empty.++data Message+    = Message [Field] String+      deriving (Show)++-- |Parse a complete message as defined by this RFC and it broken down+-- into the separate header fields and the message body. Header lines,+-- which contain syntax errors, will not cause the parser to abort.+-- Rather, these headers will appear as 'OptionalField's (which are+-- unparsed) in the resulting 'Message'. A message must be really,+-- really badly broken for this parser to fail.+--+-- This behaviour was chosen because it is impossible to predict what+-- the user of this module considers to be a fatal error;+-- traditionally, parsers are very forgiving when it comes to Internet+-- messages.+--+-- If you want to implement a really strict parser, you'll have to put+-- the appropriate parser together yourself. You'll find that this is+-- rather easy to do. Refer to the 'fields' parser for further details.++message         :: CharParser a Message+message         = do f <- fields+                     b <- option [] (do crlf+                                        b <- body+                                        return b)+                     return (Message f b)++-- |This parser will return a message body as specified by this RFC;+-- that is basically any number of 'text' characters, which may be+-- divided into separate lines by 'crlf'.++body            :: CharParser a String+body            = do r1 <- many (try (do line <- many text+                                         eol <- crlf+                                         return (line ++ eol)))+                     r2 <- many text+                     return (concat r1 ++ r2)+++-- * Field definitions (section 3.6)++-- |This data type represents any of the header fields defined in this+-- RFC. Each of the various instances contains with the return value+-- of the corresponding parser.++data Field      = OptionalField       String String+                | From                [String]+                | Sender              String+                | ReturnPath          String+                | ReplyTo             [String]+                | To                  [String]+                | Cc                  [String]+                | Bcc                 [String]+                | MessageID           String+                | InReplyTo           [String]+                | References          [String]+                | Subject             String+                | Comments            String+                | Keywords            [[String]]+                | Date                CalendarTime+                | ResentDate          CalendarTime+                | ResentFrom          [String]+                | ResentSender        String+                | ResentTo            [String]+                | ResentCc            [String]+                | ResentBcc           [String]+                | ResentMessageID     String+                | ResentReplyTo       [String]+                | 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 [String]+from            = header "From" mailbox_list++-- |Parse a \"@Sender:@\" header line and return the 'mailbox' address+-- contained in it.++sender          :: CharParser a String+sender          = header "Sender" mailbox++-- |Parse a \"@Reply-To:@\" header line and return the 'address_list'+-- address(es) contained in it.++reply_to        :: CharParser a [String]+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 [String]+to              = header "To" address_list++-- |Parse a \"@Cc:@\" header line and return the 'address_list'+-- address(es) contained in it.++cc              :: CharParser a [String]+cc              = header "Cc" address_list++-- |Parse a \"@Bcc:@\" header line and return the 'address_list'+-- address(es) contained in it.++bcc             :: CharParser a [String]+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 ++ "\"")+                     return ("[" ++ concat r ++ "]")+                  <?> "non-folding domain literal"+++-- ** Informational fields (section 3.6.5)++-- |Parse a \"@Subject:@\" header line and return it's contents verbatim.++subject         :: CharParser a String+subject         = header "Subject" unstructured++-- |Parse a \"@Comments:@\" header line and return it's contents verbatim.++comments        :: CharParser a String+comments        = header "Comments" unstructured++-- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's+-- found. Please not that each phrase is again a list of 'atom's, as+-- returned by the 'phrase' parser.++keywords        :: CharParser a [[String]]+keywords        = header "Keywords" (do r1 <- phrase+                                        r2 <- many (do char ','+                                                       r <- phrase+                                                       return r)+                                        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 [String]+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 String+resent_sender   = header "Resent-Sender" mailbox+++-- |Parse a \"@Resent-To:@\" header line and return the 'mailbox'+-- address contained in it.++resent_to       :: CharParser a [String]+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 [String]+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 [String]+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 (    do char '<'+                                 r <- choice [ try addr_spec, do { cfws; return [] } ]+                                 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 <?> "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 will match the \"obsolete angle address\" syntax. This+-- construct used to be known as a \"route address\" in earlier RFCs.+-- There are two differences between this construct and the+-- 'angle_addr': For one - as usual -, the obsolete form allows for+-- more liberal insertion of folding whitespace and comments.+--+-- Secondly, and more importantly, angle addresses used to allow the+-- (optional) specification of a \"route\". The newer version does not.+-- Such a routing address looks like this:+--+-- >    <@example1.org,@example2.org:simons@example.org>+--+-- The parser will return a tuple that - in case of the above address -+-- looks like this:+--+-- >    (["example1.org","example2.org"],"simons@example.org")+--+-- The first part contains a list of hosts that constitute the route+-- part. This list may be empty! The second part of the tuple is the+-- actual 'addr_spec' address.++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 '@'+                                    r <- domain+                                    return r)+                     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.+--+-- So, this input is perfectly valid:+--+-- >    ","+--+-- But this one is - contrary to all intuition - not:+--+-- >    "simons@example.org"+--+-- Strange, isn't it?++obs_mbox_list   :: CharParser a [String]+obs_mbox_list   = do r1 <- many1 (try (do r <- option [] mailbox+                                          unfold $ char ','+                                          return r))+                     r2 <- option [] mailbox+                     return (filter (/=[]) (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 [String]+obs_addr_list   = do r1 <- many1 (try (do r <- option [] address+                                          optional cfws+                                          char ','+                                          optional cfws+                                          return (concat r)))+                     r2 <- option [] address+                     return (filter (/=[]) (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 [String]+obs_from        = obs_header "From" mailbox_list++-- |Parse a 'sender' header line but allow for the obsolete+-- folding syntax.++obs_sender      :: CharParser a String+obs_sender      = obs_header "Sender" mailbox++-- |Parse a 'reply_to' header line but allow for the obsolete+-- folding syntax.++obs_reply_to    :: CharParser a [String]+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 [String]+obs_to          = obs_header "To" address_list++-- |Parse a 'cc' header line but allow for the obsolete+-- folding syntax.++obs_cc          :: CharParser a [String]+obs_cc          = obs_header "Cc" address_list++-- |Parse a 'bcc' header line but allow for the obsolete+-- folding syntax.++obs_bcc         :: CharParser a [String]+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 [String]+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 String+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 [String]+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 [String]+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 [String]+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 [String]+obs_resent_reply = obs_header "Resent-Reply-To" address_list+++-- ** Obsolete trace fields (section 4.5.7)++obs_return      :: CharParser a [Char]+obs_return       = obs_header "Return-Path" path++obs_received    :: CharParser a [(String, String)]+obs_received     = obs_header "Received" name_val_list++-- |Match 'obs_angle_addr'.++obs_path        :: CharParser a String+obs_path        = obs_angle_addr++-- |This parser is identical to 'optional_field' but allows the more+-- liberal line-folding syntax between the \"field_name\" and the \"field+-- text\".++obs_optional    :: CharParser a (String,String)+obs_optional    = do n <- field_name+                     many wsp+                     char ':'+                     b <- unstructured+                     crlf+                     return (n,b)+                  <?> "optional (unspecified) header line"

@@ -0,0 +1,21 @@+module Main (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 []               = []

@@ -0,0 +1,20 @@+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.

@@ -0,0 +1,13 @@+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 ]+  return ()

@@ -0,0 +1,7 @@+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

@@ -0,0 +1,22 @@+Name:           hsemail+Version:        1.0+Author:         Peter Simons <simons@cryp.to>+License:        BSD3+License-file:	LICENSE+Maintainer:     simons@cryp.to+Homepage:       http://cryp.to/hsemail/+Synopsis:       Internet Message Parsers+Description:    Parsers for the syntax defined in RFC2821 and 2822+Category:       Parsing+Build-Depends:  base, mtl, parsec+Exposed-Modules:+    Text.ParserCombinators.Parsec.Rfc2234,+    Text.ParserCombinators.Parsec.Rfc2821,+    Text.ParserCombinators.Parsec.Rfc2822+Data-files:+    README,+    prologue.txt,+    example/message-test.hs,+    example/message-test.input,+    example/smtp-test.hs,+    example/smtp-test.input

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