hsemail 1.7.7 → 2.2.2
raw patch · 15 files changed
Files
- ChangeLog.md +74/−0
- README.md +7/−0
- 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 +2/−2
- example/message-test.input +0/−20
- example/smtp-test.hs +0/−12
- example/smtp-test.input +0/−7
- hsemail.cabal +84/−35
- self-test.hs +0/−308
- src/Text/Parsec/Rfc2234.hs +176/−0
- src/Text/Parsec/Rfc2822.hs +1340/−0
- test/spec.hs +301/−0
+ ChangeLog.md view
@@ -0,0 +1,74 @@+# Change Log for hsemail++## v2.2.0++* Drop the `parsec2read` function. `Read` is not supposed to be defined+ manually, really. It's supposed to be a dual to the derived `Show` instance.+* Drop the Rfc2821 module. This code is not generic enough to be useful,+ really. I use it in [Postmaster](http://hackage.haskell.org/package/postmaster),+ and there it will live henceforth.+* `caseString` no longer returns a string; it just returns `()`.+* Make use of `DayOfWeek` type from new `time` library.+* Drop the obsolete dependency on `mtl`.++## v2.1.0++* Re-write code to use the modern `time` library rather than `old-time`.+* rfc2821: drop the entire smtp FSM stuff+* hsemail.cabal: drop unnecessary build-depends+* Drop support for GHC versions prior to 7.10.x.++## v2++* Import Data.Monoid to fix build with GHC 7.8.x.+* Ensure that `body` consumes remaining input.+* Refrain from parsing body.++## v1.7.7++* rfc2822: allow 8 bit characters is message bodys++## v1.7.6++* move the project to github++## v1.7.5++* rfc2822: support obsolete local_part syntax+* rfc2822: support obsolete domain syntax+* rfc2822: fixed typo in the parser for domain literals+* rfc2822: support obsolete quoted-pair syntax+* Greatly extend the test suite.++## v1.7.4++* rfc2822: fix `return_path` parser+* rfc2822: improve documentation (especially `subject`, `comments`)++## v1.7.3++* rfc2822: fix infinite recursion between `day` and `obs_day`++## v1.7.2++* `word` parser failed for quoted string prefixed by ws++## v1.7.1++* Updated Gero's e-mail address.++## v1.7++* Fixed plenty of GHC and HLint warnings.++## v1.6++* rfc2822: derive `Show` for new `GenericMessage` type++## v1.5++* `Message` is now usable with `ByteString` or other types as body.++## 1.4++* Initial version.
+ README.md view
@@ -0,0 +1,7 @@+hsemail+=======++[](http://hackage.haskell.org/package/hsemail)+[](http://stackage.org/lts/package/hsemail)+[](http://stackage.org/nightly/package/hsemail)+[](https://github.com/peti/hsemail/actions/workflows/haskell-ci.yml)
− Text/ParserCombinators/Parsec/Rfc2234.hs
@@ -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
− Text/ParserCombinators/Parsec/Rfc2821.hs
@@ -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))
− Text/ParserCombinators/Parsec/Rfc2822.hs
@@ -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"
− doc-test.hs
@@ -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"- ]
example/message-test.hs view
@@ -1,7 +1,7 @@ module Main (main) where -import Text.ParserCombinators.Parsec ( parse )-import Text.ParserCombinators.Parsec.Rfc2822+import Text.Parsec ( parse )+import Text.Parsec.Rfc2822 -- Read an Internet message from standard input, parse it, -- and return the result.
− example/message-test.input
@@ -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.
− example/smtp-test.hs
@@ -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 ]
− example/smtp-test.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
hsemail.cabal view
@@ -1,40 +1,89 @@-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+name: hsemail+version: 2.2.2+synopsis: Parsec parsers for the Internet Message format (e-mail)+description:+ Parsec parsers for the Internet Message format defined in RFC2822. -Extra-Source-Files: example/message-test.hs- example/message-test.input- example/smtp-test.hs- example/smtp-test.input+license: BSD3+license-file: LICENSE+author:+ Peter Simons,+ Ali Abrar,+ Gero Kriependorf,+ Marty Pauley -Source-Repository head- Type: git- Location: git://github.com/peti/hsemail.git+maintainer: Peter Simons <simons@cryp.to>+stability: stable+tested-with:+ GHC ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.8+ || ==9.6.4+ || ==9.8.1 -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+category: Parsing+homepage: https://github.com/peti/hsemail#readme+bug-reports: https://github.com/peti/hsemail/issues+build-type: Simple+extra-source-files:+ ChangeLog.md+ README.md -Test-Suite test-hsemail- type: exitcode-stdio-1.0- main-is: self-test.hs- build-depends: base, hspec, parsec, old-time+cabal-version: >=1.10 -Test-Suite doctest-hsemail- type: exitcode-stdio-1.0- main-is: doc-test.hs- build-depends: base, doctest+source-repository head+ type: git+ location: https://github.com/peti/hsemail++flag install-examples+ description: Build and install example programs.+ default: False++library+ exposed-modules:+ Text.Parsec.Rfc2234+ Text.Parsec.Rfc2822++ hs-source-dirs: src+ build-depends:+ base >=4.8.0 && <5+ , parsec >=3.1 && <3.2+ , time+ , time-compat >=1.9 && <1.10++ default-language: Haskell2010++test-suite test-hsemail+ type: exitcode-stdio-1.0+ main-is: spec.hs+ hs-source-dirs: test+ build-depends:+ base+ , hsemail+ , hspec+ , parsec+ , time++ default-language: Haskell2010++executable message-test+ main-is: message-test.hs+ hs-source-dirs: example+ default-language: Haskell2010++ if flag(install-examples)+ buildable: True+ build-depends:+ base+ , hsemail+ , parsec++ else+ buildable: False
− self-test.hs
@@ -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"
+ src/Text/Parsec/Rfc2234.hs view
@@ -0,0 +1,176 @@+{- |+ Module : Text.Parsec.Rfc2234+ Copyright : (c) 2007-2019 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.+ -}++{-# LANGUAGE FlexibleContexts #-}++module Text.Parsec.Rfc2234+ ( caseChar, caseString+ , manyN, manyNtoM+ , alpha, bit, character, cr, lf, crlf, ctl, dquote, hexdig+ , htab, lwsp, octet, sp, vchar, wsp+ , quoted_pair, quoted_string+ ) where++import Control.Monad ( liftM2, replicateM )+import Data.Char ( toUpper, chr, ord )+import Text.Parsec hiding ( crlf )++-- 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 -> 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 ((<|>) . (\x -> try (replicateM x p))) (return []) (reverse [1 .. m])+ | otherwise = liftM2 (++) (replicateM n p) (manyNtoM 0 (m - n) p)++----------------------------------------------------------------------+-- * 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
+ src/Text/Parsec/Rfc2822.hs view
@@ -0,0 +1,1340 @@+{- |+ Module : Text.Parsec.Rfc2822+ Copyright : (c) 2007-2019 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>.+-}++{-# LANGUAGE FlexibleContexts #-}++module Text.Parsec.Rfc2822 where++import Text.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string )++import Control.Monad ( replicateM, guard )+import Data.Char ( ord )+import Data.Functor+import Data.List ( intercalate )+import Data.Maybe ( catMaybes )+import Data.Monoid ( Monoid, mempty )+import Data.Time.Calendar.Compat+import Data.Time.LocalTime+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 = between nameString crlf p <?> ("obsolete " ++ n ++ " header line")+ where nameString = caseString n >> many wsp >> char ':'++-- ** 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 = concat <$> many1 (choice [fws, comment])++-- ** 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 preceding 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 preceding 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' preceding+-- 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 ((++) <$> option [] fws <*> qcontent)+ 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 ((:) <$> utext <*> option [] fws)+ 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 an appropriate 'ZonedTime'+--+-- TODO: Nor will the 'date_time' parser perform /any/ consistency checking. It+-- will accept+--+-- >>> parseTest date_time "Wed, 30 Apr 2002 13:12 +0100"+-- 2002-04-30 13:12:00 +0100++date_time :: Stream s m Char => ParsecT s u m ZonedTime+date_time = do optional (try (day_of_week >> char ','))+ d <- date+ _ <- fws+ (td, z) <- time+ optional cfws+ return (ZonedTime (LocalTime d td) z)+ <?> "date/time specification"++-- | This parser matches a 'day_name' or an 'obs_day_of_week' (optionally+-- wrapped in folding whitespace) and return the appropriate 'DayOfWeek' value.++day_of_week :: Stream s m Char => ParsecT s u m DayOfWeek+day_of_week = try (between (optional fws) (optional fws) day_name <?> "name of a day-of-the-week")+ <|> obs_day_of_week++-- | This parser recognizes abbreviated weekday names (\"@Mon@\",+-- \"@Tue@\",...).++day_name :: Stream s m Char => ParsecT s u m DayOfWeek+day_name = choice [ caseString "Mon" $> Monday+ , try (caseString "Tue" $> Tuesday)+ , caseString "Wed" $> Wednesday+ , caseString "Thu" $> Thursday+ , caseString "Fri" $> Friday+ , try (caseString "Sat" $> Saturday)+ , caseString "Sun" $> 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 Day+date = do d <- day+ m <- month+ y <- year+ return (fromGregorian (fromIntegral 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 = read <$> manyN 4 digit <?> "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 Int+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 'Int' value in the range of (1,12).++month_name :: Stream s m Char => ParsecT s u m Int+month_name = choice [ try (caseString "Jan") $> 1+ , caseString "Feb" $> 2+ , try (caseString "Mar") $> 3+ , try (caseString "Apr") $> 4+ , caseString "May" $> 5+ , try (caseString "Jun") $> 6+ , caseString "Jul" $> 7+ , caseString "Aug" $> 8+ , caseString "Sep" $> 9+ , caseString "Oct" $> 10+ , caseString "Nov" $> 11+ , caseString "Dec" $> 12+ ]+ <?> "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 = do r <- fmap read (manyNtoM 1 2 digit)+ guard (r >= 1 && r <= 31)+ return r++-- | 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 (TimeOfDay,Int) corresponding to the return values of+-- either parser.++time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone)+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 'TimeOfDay'.+--+-- >>> parseTest (time_of_day <* eof) "12:03:23"+-- 12:03:23+-- >>> parseTest (time_of_day <* eof) "99:99:99"+-- parse error at (line 1, column 3):unknown parse error++time_of_day :: Stream s m Char => ParsecT s u m TimeOfDay+time_of_day = do h <- hour+ _ <- char ':'+ m <- minute+ s <- option 0 (char ':' *> second)+ return (TimeOfDay h m (fromIntegral s))+ <?> "time specification"++-- | This parser matches a two-digit number in the range (0,24) and returns its+-- integer value.+--+-- >>> parseTest hour "034"+-- 3+-- >>> parseTest hour "99"+-- parse error at (line 1, column 3):unknown parse error++hour :: Stream s m Char => ParsecT s u m Int+hour = do r <- fmap read (replicateM 2 digit)+ guard (r >= 0 && r <= 24)+ return r+ <?> "hour"++-- | This parser will match a two-digit number in the range (0,60) and return+-- its integer value.+--+-- >>> parseTest minute "34"+-- 34+-- >>> parseTest minute "61"+-- parse error at (line 1, column 3):unknown parse error+-- >>> parseTest (minute <* eof) "034"+-- parse error at (line 1, column 3):+-- unexpected '4'+-- expecting end of input++minute :: Stream s m Char => ParsecT s u m Int+minute = do r <- fmap read (replicateM 2 digit)+ guard (r >= 0 && r <= 60)+ return r+ <?> "minute"++-- | This parser will match a two-digit number in the range (0,60) and return+-- its integer value.+--+-- >>> parseTest second "34"+-- 34++second :: Stream s m Char => ParsecT s u m Int+second = minute <?> "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 TimeZone+zone = do sign <- choice [char '+' $> 1, char '-' $> (-1)]+ h <- hour+ m <- minute+ return (minutesToTimeZone (sign * ((h * 60) + m)))+ <|> 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 (return <$> mailbox) <|> 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 = (NameAddr <$> maybeOption display_name <*> angle_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 (between (char '<') (char '>') addr_spec) <?> "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 = concat <$> sepBy address (char ',') <?> "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 r <- between (char '[') (optional fws >> char ']') (many (optional fws >> dcontent))+ 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 represents 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 = Message <$> fields <*> option mempty (crlf *> body)+++-- | 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 ZonedTime+ | ResentDate ZonedTime+ | ResentFrom [NameAddr]+ | ResentSender NameAddr+ | ResentTo [NameAddr]+ | ResentCc [NameAddr]+ | ResentBcc [NameAddr]+ | ResentMessageID String+ | ResentReplyTo [NameAddr]+ | Received ([(String,String)], ZonedTime)+ | 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 $ choice [ try (From <$> from)+ , try (Sender <$> sender)+ , try (ReturnPath <$> return_path)+ , try (ReplyTo <$> reply_to)+ , try (To <$> to)+ , try (Cc <$> cc)+ , try (Bcc <$> bcc)+ , try (MessageID <$> message_id)+ , try (InReplyTo <$> in_reply_to)+ , try (References <$> references)+ , try (Subject <$> subject)+ , try (Comments <$> comments)+ , try (Keywords <$> keywords)+ , try (Date <$> orig_date)+ , try (ResentDate <$> resent_date)+ , try (ResentFrom <$> resent_from)+ , try (ResentSender <$> resent_sender)+ , try (ResentTo <$> resent_to)+ , try (ResentCc <$> resent_cc)+ , try (ResentBcc <$> resent_bcc)+ , try (ResentMessageID <$> resent_msg_id)+ , try (Received <$> received)+ , uncurry OptionalField <$> optional_field -- catch all+ ]++-- ** 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 ZonedTime+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 <|> (optional cfws $> []))++-- ** 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 occurrences 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 occurrences 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" ((:) <$> phrase <*> many (char ',' *> phrase))+++-- ** Resent fields (section 3.6.6)++-- | Parse a \"@Resent-Date:@\" header line and return the date it contains as+-- 'ZonedTime'.++resent_date :: Stream s m Char => ParsecT s u m ZonedTime+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 <|> (optional cfws $> []))+ <?> "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)], ZonedTime)+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 = 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 (concat <$> many1 angle_addr)+ , 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.++{-# ANN optional_field "HLint: ignore Reduce duplication" #-}++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 "."+ , cfws $> []+ ]+ 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. TODO++obs_day_of_week :: Stream s m Char => ParsecT s u m DayOfWeek+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 (normalize . read <$> manyN 2 digit) <?> "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 Int+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 TimeZone+obs_zone = choice [ parseZone "UT" 0+ , parseZone "GMT" 0+ , parseZone "EST" (-5)+ , parseZone "EDT" (-4)+ , parseZone "CST" (-6)+ , parseZone "CDT" (-5)+ , parseZone "MST" (-7)+ , parseZone "MDT" (-6)+ , parseZone "PST" (-8)+ , parseZone "PDT" (-7)+ , do r <- oneOf ['A' .. 'I']+ mkZone (ord r - 64)+ <?> "military zone spec"+ , do r <- oneOf ['K' .. 'M']+ mkZone (ord r - 65)+ <?> "military zone spec"+ , do r <- oneOf ['N' .. 'Y']+ mkZone (-(ord r - 77))+ <?> "military zone spec"+ , parseZone "Z" 0 <?> "military zone spec"+ ]+ where+ parseZone n o = try (string n *> mkZone o)+ mkZone = pure . hoursToTimeZone++-- * 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 (obs_domain_list <* char ':') <?> "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 $ choice [ try (From <$> obs_from)+ , try (Sender <$> obs_sender)+ , try (ReturnPath <$> obs_return)+ , try (ReplyTo <$> obs_reply_to)+ , try (To <$> obs_to)+ , try (Cc <$> obs_cc)+ , try (Bcc <$> obs_bcc)+ , try (MessageID <$> obs_message_id)+ , try (InReplyTo <$> obs_in_reply_to)+ , try (References <$> obs_references)+ , try (Subject <$> obs_subject)+ , try (Comments <$> obs_comments)+ , try (Keywords . return <$> obs_keywords)+ , try (Date <$> obs_orig_date)+ , try (ResentDate <$> obs_resent_date)+ , try (ResentFrom <$> obs_resent_from)+ , try (ResentSender <$> obs_resent_send)+ , try (ResentTo <$> obs_resent_to)+ , try (ResentCc <$> obs_resent_cc)+ , try (ResentBcc <$> obs_resent_bcc)+ , try (ResentMessageID <$> obs_resent_mid)+ , try (ResentReplyTo <$> obs_resent_reply)+ , try (ObsReceived <$> obs_received)+ , uncurry OptionalField <$> obs_optional -- catch all+ ]++-- ** 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 ZonedTime+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 <|> (optional cfws $> []))+++-- ** 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 ((phrase $> []) <|> 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 ((phrase $> []) <|> 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 ZonedTime+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 <|> (optional cfws $> []))++-- | 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"
+ test/spec.hs view
@@ -0,0 +1,301 @@+module Main ( main ) where++import Text.Parsec.Rfc2822++import Data.Time.Calendar+import Data.Time.LocalTime+import Test.Hspec+import Text.Parsec ( parse, eof )+import Text.Parsec.String ( Parser )++parseTest :: Parser a -> String -> IO a+parseTest p input = case parse (p <* eof) (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" $+ fmap zonedTimeToUTC (parseTest date_time "Fri, 21 Dec 2012 00:07:43 +0300") `shouldReturn`+ zonedTimeToUTC (ZonedTime (LocalTime (fromGregorian 2012 12 21) (TimeOfDay 0 7 43)) (hoursToTimeZone 3))++ describe "Rfc2822.day" $ do+ it "parses a hand-picked day-of-months correctly" $ do+ parseTest day "1" `shouldReturn` 1+ parseTest day "09" `shouldReturn` 9+ parseTest day "15" `shouldReturn` 15+ parseTest day "31" `shouldReturn` 31++ it "does perform range checking" $ do+ parseFailure day "00"+ parseFailure day "32"++ 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"