diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,16 @@ # 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`. diff --git a/hsemail.cabal b/hsemail.cabal --- a/hsemail.cabal +++ b/hsemail.cabal @@ -1,8 +1,7 @@ name: hsemail -version: 2.1.0 -synopsis: Parsec parsers for the RFC2822 Internet Message format -description: Parsec parsers for the Internet Message format defined in RFC 2821 and - 2822. +version: 2.2.0 +synopsis: Parsec parsers for the Internet Message format (e-mail) +description: Parsec parsers for the Internet Message format defined in RFC2822. license: BSD3 license-file: LICENSE author: Peter Simons, @@ -26,11 +25,9 @@ library exposed-modules: Text.Parsec.Rfc2234 - Text.Parsec.Rfc2821 Text.Parsec.Rfc2822 - other-modules: Paths_hsemail hs-source-dirs: src - build-depends: base > 4.8 && < 5, mtl, parsec >= 3.1, time + build-depends: base > 4.8 && < 5, parsec == 3.1.*, time, time-compat == 1.9.* default-language: Haskell2010 test-suite test-hsemail diff --git a/src/Text/Parsec/Rfc2234.hs b/src/Text/Parsec/Rfc2234.hs --- a/src/Text/Parsec/Rfc2234.hs +++ b/src/Text/Parsec/Rfc2234.hs @@ -16,12 +16,17 @@ {-# LANGUAGE FlexibleContexts #-} -module Text.Parsec.Rfc2234 where +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) -import qualified Text.Parsec.String as PS +import Text.Parsec hiding ( crlf ) -- Customize hlint ... {-# ANN module "HLint: ignore Use camelCase" #-} @@ -30,162 +35,142 @@ -- * Parser Combinators ---------------------------------------------------------------------- --- |Case-insensitive variant of Parsec's 'char' function. +-- | 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) +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. +-- | Case-insensitive variant of Parsec's 'string' function. -caseString :: Stream s m Char => String -> ParsecT s u m String -caseString cs = mapM caseChar cs cs +caseString :: Stream s m Char => String -> ParsecT s u m () +caseString cs = mapM_ caseChar cs cs --- |Match a parser at least @n@ times. +-- | Match a parser at least @n@ times. --- manyN :: Int -> GenParser a b c -> GenParser a b [c] manyN :: Int -> ParsecT s u m a -> ParsecT s u m [a] -manyN n p - | n <= 0 = return [] - | otherwise = liftM2 (++) (replicateM n p) (many p) +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. +-- | 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 :: 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) - --- |Helper function to generate 'Parser'-based instances for --- the 'Read' class. - -parsec2read :: PS.Parser a -> String -> [(a, String)] -parsec2read f x = either (error . show) id (parse f' "" x) - where - f' = do { a <- f; res <- getInput; return [(a,res)] } - + | 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. +-- | 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" +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\". +-- | Match either \"1\" or \"0\". -bit :: Stream s m Char => ParsecT s u m Char -bit = oneOf "01" "bit ('0' or '1')" +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). +-- | 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" +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@. +-- | Match the carriage return character @\\r@. -cr :: Stream s m Char => ParsecT s u m Char -cr = char '\r' "carriage return" +cr :: Stream s m Char => ParsecT s u m Char +cr = char '\r' "carriage return" --- |Match returns the linefeed character @\\n@. +-- | Match returns the linefeed character @\\n@. -lf :: Stream s m Char => ParsecT s u m Char -lf = char '\n' "linefeed" +lf :: Stream s m Char => ParsecT s u m Char +lf = char '\n' "linefeed" --- |Match the Internet newline @\\r\\n@. +-- | 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" +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]. +-- | 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" +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 \"@\"@\". +-- | Match the double quote character \"@\"@\". -dquote :: Stream s m Char => ParsecT s u m Char -dquote = char (chr 34) "double quote" +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. +-- | 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" +hexdig :: Stream s m Char => ParsecT s u m Char +hexdig = hexDigit "hexadecimal digit" --- |Match the tab (\"@\\t@\") character. +-- | Match the tab (\"@\\t@\") character. -htab :: Stream s m Char => ParsecT s u m Char -htab = char '\t' "horizontal tab" +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'. +-- | 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" +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 /any/ character. +octet :: Stream s m Char => ParsecT s u m Char +octet = anyChar "any 8-bit character" --- |Match the space. +-- | Match the space. -sp :: Stream s m Char => ParsecT s u m Char -sp = char ' ' "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]. +-- | 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" +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'. +-- | Match either 'sp' or 'htab'. -wsp :: Stream s m Char => ParsecT s u m Char -wsp = sp <|> htab "white-space" +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. +-- | 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" +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. +-- | 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 +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 diff --git a/src/Text/Parsec/Rfc2821.hs b/src/Text/Parsec/Rfc2821.hs deleted file mode 100644 --- a/src/Text/Parsec/Rfc2821.hs +++ /dev/null @@ -1,397 +0,0 @@ -{- | - Module : Text.Parsec.Rfc2821 - Copyright : (c) 2007-2019 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\", . - -} - -{-# LANGUAGE FlexibleContexts #-} - -module Text.Parsec.Rfc2821 where - -import Text.Parsec.Rfc2234 - -import Control.Exception ( assert ) -import Control.Monad.State -import Data.Char ( toLower ) -import Data.List ( intercalate ) -import Text.Parsec hiding (crlf) - --- Customize hlint ... -{-# ANN module "HLint: ignore Use camelCase" #-} - ----------------------------------------------------------------------- --- * Data Types for ESMTP 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 EsmtpCmd - = 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 EsmtpCmd 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" []) = "" - 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 :: Mailbox -postmaster = Mailbox [] "postmaster" [] - - ----------------------------------------------------------------------- --- * Data Types for ESMTP Replies ----------------------------------------------------------------------- - --- | An ESMTP 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 EsmtpReply = Reply EsmtpCode [String] - -data EsmtpCode = 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 EsmtpReply 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 EsmtpCode 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] -> EsmtpReply -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 :: EsmtpReply -> 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 :: EsmtpReply -> Bool -isFailure (Reply (Code PermanentFailure _ _) _) = True -isFailure (Reply (Code TransientFailure _ _) _) = True -isFailure _ = False - --- | The replies @221@ and @421@ signify 'Shutdown'. - -isShutdown :: EsmtpReply -> Bool -isShutdown (Reply (Code Success Connection 1) _) = True -isShutdown (Reply (Code TransientFailure Connection 1) _) = True -isShutdown _ = False - ----------------------------------------------------------------------- --- * Command Parsers ----------------------------------------------------------------------- - --- | This parser recognizes any of the ESMTP commands defined below. Note that --- /all/ command parsers expect their input to be terminated with 'crlf'. - -smtpCmd :: Stream s m Char => ParsecT s u m EsmtpCmd - -smtpCmd = choice - [ smtpData, rset, noop, quit, turn - , helo, mail, rcpt, send, soml, saml - , vrfy, expn, help, ehlo - ] - --- | The parser name \"data\" was taken. -smtpData :: Stream s m Char => ParsecT s u m EsmtpCmd -rset, quit, turn, helo, ehlo, mail :: Stream s m Char => ParsecT s u m EsmtpCmd -rcpt, send, soml, saml, vrfy, expn :: Stream s m Char => ParsecT s u m EsmtpCmd -help :: Stream s m Char => ParsecT s u m EsmtpCmd - --- | May have an optional 'word' argument, but it is ignored. -noop :: Stream s m Char => ParsecT s u m EsmtpCmd - -smtpData = mkCmd0 "DATA" Data -rset = mkCmd0 "RSET" Rset -quit = mkCmd0 "QUIT" Quit -turn = mkCmd0 "TURN" Turn -helo = mkCmd1 "HELO" Helo domain -ehlo = mkCmd1 "EHLO" Ehlo domain -mail = mkCmd1 "MAIL" MailFrom from_path -rcpt = mkCmd1 "RCPT" RcptTo to_path -send = mkCmd1 "SEND" Send from_path -soml = mkCmd1 "SOML" Soml from_path -saml = mkCmd1 "SAML" Saml from_path -vrfy = mkCmd1 "VRFY" Vrfy word -expn = mkCmd1 "EXPN" Expn word - -help = try (mkCmd0 "HELP" (Help [])) <|> - mkCmd1 "HELP" Help (option [] word) - -noop = try (mkCmd0 "NOOP" Noop) <|> - mkCmd1 "NOOP" (const Noop) (option [] word) - - ----------------------------------------------------------------------- --- * Argument Parsers ----------------------------------------------------------------------- - -from_path :: Stream s m Char => ParsecT s u m Mailbox -from_path = do - caseString "from:" - (try (string "<>" >> return nullPath) <|> path) - "from-path" - -to_path :: Stream s m Char => ParsecT s u m Mailbox -to_path = do - caseString "to:" - (try (caseString "" >> return postmaster) - <|> path) "to-path" - -path :: Stream s m Char => ParsecT s u m Mailbox -path = between (char '<') (char '>') (p "path") - where - p = do - r1 <- option [] (a_d_l >>= \r -> char ':' >> return r) - (Mailbox _ l d) <- mailbox - return (Mailbox r1 l d) - -mailbox :: Stream s m Char => ParsecT s u m Mailbox -mailbox = (Mailbox [] <$> local_part <* char '@' <*> domain) "mailbox" - -local_part :: Stream s m Char => ParsecT s u m String -local_part = (dot_string <|> quoted_string) "local-part" - -domain :: Stream s m Char => ParsecT s u m String -domain = choice - [ tokenList subdomain '.' "domain" - , address_literal "address literal" - ] - -a_d_l :: Stream s m Char => ParsecT s u m [String] -a_d_l = sepBy1 at_domain (char ',') "route-list" - -at_domain :: Stream s m Char => ParsecT s u m String -at_domain = (char '@' >> domain) "at-domain" - --- | /TODO/: Add IPv6 address and general literals -address_literal :: Stream s m Char => ParsecT s u m String -address_literal = ipv4_literal "IPv4 address literal" - -ipv4_literal :: Stream s m Char => ParsecT s u m String -ipv4_literal = do - rs <- between (char '[') (char ']') ipv4addr - return ('[': reverse (']': reverse rs)) - -ipv4addr :: Stream s m Char => ParsecT s u m String -ipv4addr = p "IPv4 address literal" - where - p = do - r1 <- snum - r2 <- char '.' >> snum - r3 <- char '.' >> snum - r4 <- char '.' >> snum - return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4) - -subdomain :: Stream s m Char => ParsecT s u m String -subdomain = p "domain name" - where - p = do - r <- many1 (alpha <|> digit <|> char '-') - if last r == '-' - then fail "subdomain must not end with hyphen" - else return r - -dot_string :: Stream s m Char => ParsecT s u m String -dot_string = tokenList atom '.' "dot_string" - -atom :: Stream s m Char => ParsecT s u m String -atom = many1 atext "atom" - where - atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" - -snum :: Stream s m Char => ParsecT s u m String -snum = do - r <- manyNtoM 1 3 digit - if (read r :: Int) > 255 - then fail "IP address parts must be 0 <= x <= 255" - else return r - -number :: Stream s m Char => ParsecT s u m String -number = many1 digit - --- | This is a useful addition: The parser accepts an 'atom' or a --- 'quoted_string'. - -word :: Stream s m Char => ParsecT s u m String -word = (atom <|> fmap show quoted_string) - "word or quoted-string" - - ----------------------------------------------------------------------- --- * Helper Functions ----------------------------------------------------------------------- - --- | Make the string 'crlf' terminated no matter what. \'@\\n@\' is expanded, --- otherwise 'crlf' is appended. Note that if the string was terminated --- incorrectly before, it still is. This function is useful when reading input --- with 'System.IO.hGetLine' which removes the end-of-line delimiter. - -{-# ANN fixCRLF "HLint: ignore Use list literal pattern" #-} -fixCRLF :: String -> String -fixCRLF ('\r' :'\n':[]) = fixCRLF [] -fixCRLF ( x :'\n':[]) = x : fixCRLF [] -fixCRLF ( x : xs ) = x : fixCRLF xs -fixCRLF [ ] = "\r\n" - --- | Construct a parser for a command without arguments. Expects 'crlf'! - -mkCmd0 :: Stream s m Char => String -> a -> ParsecT s u m a -mkCmd0 str cons = (do - try (caseString str) - _ <- skipMany wsp >> crlf - return cons) str - --- | Construct a parser for a command with an argument, which the given parser --- will handle. The result of the argument parser will be applied to the type --- constructor before it is returned. Expects 'crlf'! - -mkCmd1 :: Stream s m Char => String -> (a -> EsmtpCmd) -> ParsecT s u m a - -> ParsecT s u m EsmtpCmd -mkCmd1 str cons p = do - try (caseString str) - _ <- wsp - input <- getInput - st <- getState - let eol = skipMany wsp >> crlf - p' = between (many wsp) eol p str - r <- lift $ runParserT p' st "" input - case r of - Left e -> return (WrongArg str e) - Right a -> return (cons a) - --- | @tokenList p '.'@ will parse a token of the form \"@p.p@\", or --- \"@p.p.p@\", and so on. Used in 'domain' and 'dot_string', for example. - -tokenList :: Stream s m Char => ParsecT s u m String -> Char -> ParsecT s u m String -tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c)) diff --git a/src/Text/Parsec/Rfc2822.hs b/src/Text/Parsec/Rfc2822.hs --- a/src/Text/Parsec/Rfc2822.hs +++ b/src/Text/Parsec/Rfc2822.hs @@ -23,1383 +23,1318 @@ import Data.List ( intercalate ) import Data.Maybe ( catMaybes ) import Data.Monoid ( Monoid, mempty ) -import Data.Time.Calendar -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 = let nameString = caseString n >> many wsp >> char ':' - in - between nameString crlf p ("obsolete " ++ n ++ " header line") - - --- ** Primitive Tokens (section 3.2.1) - --- |Match any US-ASCII non-whitespace control character. - -no_ws_ctl :: Stream s m Char => ParsecT s u m Char -no_ws_ctl = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127])) - "US-ASCII non-whitespace control character" - --- |Match any US-ASCII character except for @\r@, @\n@. - -text :: Stream s m Char => ParsecT s u m Char -text = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127])) - "US-ASCII character (excluding CR and LF)" - --- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@. - -specials :: Stream s m Char => ParsecT s u m Char -specials = oneOf "()<>[]:;@,.\\\"" "one of ()<>[]:;@,.\\\"" - - --- ** Quoted characters (section 3.2.2) - --- |Match a \"quoted pair\". All characters matched by 'text' may be --- quoted. Note that the parsers returns /both/ characters, the --- backslash and the actual content. - -quoted_pair :: Stream s m Char => ParsecT s u m String -quoted_pair = try obs_qp <|> do { _ <- char '\\'; r <- text; return ['\\',r] } - "quoted pair" - --- ** Folding white space and comments (section 3.2.3) - --- |Match \"folding whitespace\". That is any combination of 'wsp' and --- 'crlf' followed by 'wsp'. - -fws :: Stream s m Char => ParsecT s u m String -fws = do r <- many1 $ choice [ blanks, linebreak] - return (concat r) - where - blanks = many1 wsp - linebreak = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) } - --- |Match any non-whitespace, non-control character except for \"@(@\", --- \"@)@\", and \"@\\@\". This is used to describe the legal content of --- 'comment's. --- --- /Note/: This parser accepts 8-bit characters, even though this is --- not legal according to the RFC. Unfortunately, 8-bit content in --- comments has become fairly common in the real world, so we'll just --- accept the fact. - -ctext :: Stream s m Char => ParsecT s u m Char -ctext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255])) - "any regular character (excluding '(', ')', and '\\')" - --- |Match a \"comments\". That is any combination of 'ctext', --- 'quoted_pair's, and 'fws' between brackets. Comments may nest. - -comment :: Stream s m Char => ParsecT s u m String -comment = do _ <- char '(' - r1 <- many ccontent - r2 <- option [] fws - _ <- char ')' - return ("(" ++ concat r1 ++ r2 ++ ")") - "comment" - where - ccontent = try $ do r1 <- option [] fws - r2 <- choice [many1 ctext, quoted_pair, comment] - return (r1 ++ r2) - --- |Match any combination of 'fws' and 'comments'. - -cfws :: Stream s m Char => ParsecT s u m String -cfws = do r <- many1 $ choice [ fws, comment ] - return (concat r) - --- ** Atom (section 3.2.4) - --- |Match any US-ASCII character except for control characters, --- 'specials', or space. 'atom' and 'dot_atom' are made up of this. - -atext :: Stream s m Char => ParsecT s u m Char -atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" - "US-ASCII character (excluding controls, space, and specials)" - --- |Match one or more 'atext' characters and skip any 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 (do r1 <- option [] fws - r2 <- qcontent - return (r1 ++ r2)) - r2 <- option [] fws - _ <- dquote - return ("\"" ++ concat r1 ++ r2 ++ "\"")) - "quoted string" - - --- * Miscellaneous tokens (section 3.2.6) - --- |Match either 'atom' or 'quoted_string'. - -word :: Stream s m Char => ParsecT s u m String -word = unfold (atom <|> quoted_string) "word" - --- |Match either one or more 'word's or an 'obs_phrase'. - -phrase :: Stream s m Char => ParsecT s u m [String] -phrase = {- many1 word "phrase" <|> -} obs_phrase - --- |Match any non-whitespace, non-control US-ASCII character except --- for \"@\\@\" and \"@\"@\". - -utext :: Stream s m Char => ParsecT s u m Char -utext = no_ws_ctl <|> satisfy (\c -> ord c `elem` [33..126]) - "regular US-ASCII character (excluding '\\', and '\"')" - --- |Match any number of 'utext' tokens. --- --- \"Unstructured text\" is used in free text fields such as 'subject'. --- Please note that any comments or whitespace that prefaces or --- follows the actual 'utext' is /included/ in the returned string. - -unstructured :: Stream s m Char => ParsecT s u m String -unstructured = do r1 <- option [] fws - r2 <- many (do r3 <- utext - r4 <- option [] fws - return (r3 : r4)) - return (r1 ++ concat r2) - "unstructured text" - - --- * Date and Time Specification (section 3.3) - --- |Parse a date and time specification of the form --- --- > Thu, 19 Dec 2002 20:35:46 +0200 --- --- where the weekday specification \"@Thu,@\" is optional. The parser --- returns 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 ',')) - day <- date - _ <- fws - (td,z) <- time - optional cfws - return (ZonedTime (LocalTime day td) z) - "date/time specification" - --- |This parser matches a 'day_name' or an 'obs_day_of_week' (optionally --- wrapped in folding whitespace) and return its 'Day' value. - -day_of_week :: Stream s m Char => ParsecT s u m String -day_of_week = try (between (optional fws) (optional fws) day_name "name of a day-of-the-week") - <|> obs_day_of_week - --- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...) --- and return the appropriate 'Day' value. - -day_name :: Stream s m Char => ParsecT s u m String -day_name = caseString "Mon" - <|> try (caseString "Tue") - <|> caseString "Wed" - <|> caseString "Thu" - <|> caseString "Fri" - <|> try (caseString "Sat") - <|> caseString "Sun" - "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 = do y <- manyN 4 digit - return (read y :: Int) - "year" - --- |This parser will match a 'month_name', optionally wrapped in --- folding whitespace, or an 'obs_month' and return its 'Month' --- value. - -month :: Stream s m Char => ParsecT s u m 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 = (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 (do { _ <- 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 (do { r <- mailbox; return [r] }) <|> group - "address" - --- |Parse a 'name_addr' or an 'addr_spec' and return the --- address. - -mailbox :: Stream s m Char => ParsecT s u m NameAddr -mailbox = try name_addr <|> fmap (NameAddr Nothing) addr_spec - "mailbox" - --- |Parse an 'angle_addr', optionally prefaced with a 'display_name', --- and return the address. - -name_addr :: Stream s m Char => ParsecT s u m NameAddr -name_addr = (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 (do _ <- char '<' - r <- addr_spec - _ <- char '>' - return r) - "angle address" - ) - <|> obs_angle_addr - --- |Parse a \"group\" of addresses. That is a 'display_name', followed --- by a colon, optionally followed by a 'mailbox_list', followed by a --- semicolon. The found address(es) are returned - what may be none. --- Here is an example: --- --- >>> parse group "" "my group: user1@example.org, user2@example.org;" --- Right [NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user1@example.org"},NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user2@example.org"}] - -group :: Stream s m Char => ParsecT s u m [NameAddr] -group = do _ <- display_name - _ <- char ':' - r <- option [] mailbox_list - _ <- unfold $ char ';' - return r - "address group" - --- |Parse and return a 'phrase'. - -display_name :: Stream s m Char => ParsecT s u m String -display_name = fmap unwords phrase - "display name" - --- |Parse a list of 'mailbox' addresses, every two addresses being --- separated by a comma, and return the list of found address(es). - -mailbox_list :: Stream s m Char => ParsecT s u m [NameAddr] -mailbox_list = sepBy mailbox (char ',') "mailbox list" - --- |Parse a list of 'address' addresses, every two addresses being --- separated by a comma, and return the list of found address(es). - -address_list :: Stream s m Char => ParsecT s u m [NameAddr] -address_list = do { r <-sepBy address (char ','); return (concat r) } - "address list" - - --- ** Addr-spec specification (section 3.4.1) - --- |Parse an \"address specification\". That is a 'local_part', followed --- by an \"@\@@\" character, followed by a 'domain'. Return the complete --- address as 'String', ignoring any whitespace or any comments. - -addr_spec :: Stream s m Char => ParsecT s u m String -addr_spec = do r1 <- local_part - _ <- char '@' - r2 <- domain - return (r1 ++ "@" ++ r2) - "address specification" - --- |Parse and return a \"local part\" of an 'addr_spec'. That is either --- a 'dot_atom' or a 'quoted_string'. - -local_part :: Stream s m Char => ParsecT s u m String -local_part = try obs_local_part <|> dot_atom <|> quoted_string - "address' local part" - --- |Parse and return a \"domain part\" of an 'addr_spec'. That is either --- a 'dot_atom' or a 'domain_literal'. - -domain :: Stream s m Char => ParsecT s u m String -domain = try obs_domain <|> dot_atom <|> domain_literal - "address' domain part" - --- |Parse a \"domain literal\". That is a \"@[@\" character, followed by --- any amount of 'dcontent', followed by a terminating \"@]@\" --- character. The complete string is returned verbatim. - -domain_literal :: Stream s m Char => ParsecT s u m String -domain_literal = unfold (do _ <- char '[' - r <- many (optional fws >> dcontent) - optional fws - _ <- char ']' - return ("[" ++ concat r ++ "]")) - "domain literal" - --- |Parse and return any characters that are legal in a --- 'domain_literal'. That is 'dtext' or a 'quoted_pair'. - -dcontent :: Stream s m Char => ParsecT s u m String -dcontent = many1 dtext <|> quoted_pair - "domain literal content" - --- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and --- \"@\\@\". - -dtext :: Stream s m Char => ParsecT s u m Char -dtext = no_ws_ctl - <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94..126])) - "any ASCII character (excluding '[', ']', and '\\')" - - --- * Overall message syntax (section 3.5) - --- |This data type 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 = do f <- fields - b <- option mempty (do _ <- crlf; body) - return (Message f b) - --- |A message body is just an unstructured sequence of characters. - -body :: (Monoid s, Monad m) => ParsecT s u m s -body = do v <- getInput - setInput mempty - return v - --- * Field definitions (section 3.6) - --- |This data type represents any of the header fields defined in this --- RFC. Each of the various instances contains with the return value --- of the corresponding parser. - -data Field = OptionalField String String - | From [NameAddr] - | Sender NameAddr - | ReturnPath String - | ReplyTo [NameAddr] - | To [NameAddr] - | Cc [NameAddr] - | Bcc [NameAddr] - | MessageID String - | InReplyTo [String] - | References [String] - | Subject String - | Comments String - | Keywords [[String]] - | Date 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 <|> do { optional cfws; return [] }) - --- ** Identification fields (section 3.6.4) - --- |Parse a \"@Message-Id:@\" header line and return the 'msg_id' --- contained in it. - -message_id :: Stream s m Char => ParsecT s u m String -message_id = header "Message-ID" msg_id - --- |Parse a \"@In-Reply-To:@\" header line and return the list of --- 'msg_id's contained in it. - -in_reply_to :: Stream s m Char => ParsecT s u m [String] -in_reply_to = header "In-Reply-To" (many1 msg_id) - --- |Parse a \"@References:@\" header line and return the list of --- 'msg_id's contained in it. - -references :: Stream s m Char => ParsecT s u m [String] -references = header "References" (many1 msg_id) - --- |Parse a \"@message ID:@\" and return it. A message ID is almost --- identical to an 'angle_addr', but with stricter rules about folding --- and whitespace. - -msg_id :: Stream s m Char => ParsecT s u m String -msg_id = unfold (do _ <- char '<' - idl <- id_left - _ <- char '@' - idr <- id_right - _ <- char '>' - return ("<" ++ idl ++ "@" ++ idr ++ ">")) - "message ID" - --- |Parse a \"left ID\" part of a 'msg_id'. This is almost identical to --- the 'local_part' of an e-mail address, but with stricter rules --- about folding and whitespace. - -id_left :: Stream s m Char => ParsecT s u m String -id_left = dot_atom_text <|> no_fold_quote - "left part of an message ID" - --- |Parse a \"right ID\" part of a 'msg_id'. This is almost identical to --- the 'domain' of an e-mail address, but with stricter rules about --- folding and whitespace. - -id_right :: Stream s m Char => ParsecT s u m String -id_right = dot_atom_text <|> no_fold_literal - "right part of an message ID" - --- |Parse one or more 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" (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 '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 - <|> do optional cfws - return [] - ) - "Resent-Bcc: header line" - --- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msg_id' --- contained in it. - -resent_msg_id :: Stream s m Char => ParsecT s u m String -resent_msg_id = header "Resent-Message-ID" msg_id - - --- ** Trace fields (section 3.6.7) - -return_path :: Stream s m Char => ParsecT s u m String -return_path = header "Return-Path" path - -path :: Stream s m Char => ParsecT s u m String -path = unfold ( try (do _ <- char '<' - r <- option "" addr_spec - _ <- char '>' - return ("<" ++ r ++ ">") - ) - <|> obs_path - ) - "return path spec" - -received :: Stream s m Char => ParsecT s u m ([(String,String)], 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 = do optional cfws - many1 name_val_pair - "list of name/value pairs" - -name_val_pair :: Stream s m Char => ParsecT s u m (String,String) -name_val_pair = do r1 <- item_name - _ <- cfws - r2 <- item_value - return (r1,r2) - "a name/value pair" - -item_name :: Stream s m Char => ParsecT s u m String -item_name = do r1 <- alpha - r2 <- many $ choice [ char '-', alpha, digit ] - return (r1 : r2) - "name of a name/value pair" - -item_value :: Stream s m Char => ParsecT s u m String -item_value = choice [ try (do { r <- many1 angle_addr; return (concat r) }) - , try addr_spec - , try domain - , msg_id - , try atom - ] - "value of a name/value pair" - --- ** Optional fields (section 3.6.8) - --- |Parse an arbitrary header field and return a tuple containing the --- 'field_name' and 'unstructured' text of the header. The name will --- /not/ contain the terminating colon. - -{-# 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 "." - , do { _ <- cfws; return [] } - ] - return (r1 : filter (/=[]) r2) - --- |Match a \"phrase list\" syntax and return the list of 'String's --- that make up the phrase. In contrast to a 'phrase', the --- 'obs_phrase_list' separates the individual words by commas. This --- syntax is - as you will have guessed - obsolete. - -obs_phrase_list :: Stream s m Char => ParsecT s u m [String] -obs_phrase_list = do r1 <- many1 (do r <- option [] phrase - _ <- unfold $ char ',' - return (filter (/=[]) r)) - r2 <- option [] phrase - return (concat r1 ++ r2) - <|> phrase - - --- * Obsolete folding white space (section 4.2) - --- |Parse and return an \"obsolete fws\" token. That is at least one --- 'wsp' character, followed by an arbitrary number (including zero) --- of 'crlf' followed by at least one more 'wsp' character. - -obs_fws :: Stream s m Char => ParsecT s u m String -obs_fws = do r1 <- many1 wsp - r2 <- many (do r3 <- crlf - r4 <- many1 wsp - return (r3 ++ r4)) - return (r1 ++ concat r2) - - --- * Obsolete Date and Time (section 4.3) - --- |Parse a 'day_name' but allow for the obsolete folding syntax. --- TODO - -obs_day_of_week :: Stream s m Char => ParsecT s u m String -obs_day_of_week = unfold day_name "day-of-the-week name" - --- |Parse a 'year' but allow for a two-digit number (obsolete) and the --- obsolete folding syntax. - -obs_year :: Stream s m Char => ParsecT s u m Int -obs_year = unfold (do r <- manyN 2 digit - return (normalize (read r :: Int))) - "year" - where - normalize n - | n <= 49 = 2000 + n - | n <= 999 = 1900 + n - | otherwise = n - --- |Parse a 'month_name' but allow for the obsolete folding syntax. - -obs_month :: Stream s m Char => ParsecT s u m 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 "" - -obs_angle_addr :: Stream s m Char => ParsecT s u m String -obs_angle_addr = unfold (do _ <- char '<' - _ <- option [] obs_route - addr <- addr_spec - _ <- char '>' - return ("<" ++ addr ++ ">") -- TODO: route is lost here. - ) - "obsolete angle address" - --- |This parser parses the \"route\" part of 'obs_angle_addr' and --- returns the list of 'String's that make up this route. Relies on --- 'obs_domain_list' for the actual parsing. - -obs_route :: Stream s m Char => ParsecT s u m [String] -obs_route = unfold (do { r <- obs_domain_list; _ <- char ':'; return r }) - "route of an obsolete angle address" - --- |This parser parses a list of domain names, each of them prefaced --- with an \"at\". Multiple names are separated by a comma. The list of --- 'domain's is returned - and may be empty. - -obs_domain_list :: Stream s m Char => ParsecT s u m [String] -obs_domain_list = do _ <- char '@' - r1 <- domain - r2 <- many (do _ <- cfws <|> string "," - optional cfws - _ <- char '@' - domain) - return (r1 : r2) - "route of an obsolete angle address" - --- |Parse the obsolete syntax of a 'local_part', which allowed for --- more liberal insertion of folding whitespace and comments. The --- actual string is returned. - -obs_local_part :: Stream s m Char => ParsecT s u m String -obs_local_part = do r1 <- word - r2 <- many (do _ <- string "." - r <- word - return ('.' : r)) - return (r1 ++ concat r2) - "local part of an address" - --- |Parse the obsolete syntax of a 'domain', which allowed for more --- liberal insertion of folding whitespace and comments. The actual --- string is returned. - -obs_domain :: Stream s m Char => ParsecT s u m String -obs_domain = do r1 <- atom - r2 <- many (do _ <- string "." - r <- atom - return ('.' : r)) - return (r1 ++ concat r2) - "domain part of an address" - --- |This parser will match the obsolete syntax for a 'mailbox_list'. --- This one is quite weird: An 'obs_mbox_list' contains an arbitrary --- number of 'mailbox'es - including none -, which are separated by --- commas. But you may have multiple consecutive commas without giving --- a 'mailbox'. You may also have a valid 'obs_mbox_list' that --- contains /no/ 'mailbox' at all. On the other hand, you /must/ have --- at least one comma. The following example is valid: --- --- >>> parse obs_mbox_list "" "," --- Right [] --- --- But this one is not: --- --- >>> parse obs_mbox_list "" "joe@example.org" --- Left (line 1, column 16): --- unexpected end of input --- expecting obsolete syntax for a list of mailboxes - -obs_mbox_list :: Stream s m Char => ParsecT s u m [NameAddr] -obs_mbox_list = do r1 <- many1 (try (do r <- maybeOption mailbox - _ <- unfold $ char ',' - return r)) - r2 <- maybeOption mailbox - return (catMaybes (r1 ++ [r2])) - "obsolete syntax for a list of mailboxes" - --- |This parser is identical to 'obs_mbox_list' but parses a list of --- 'address'es rather than 'mailbox'es. The main difference is that an --- 'address' may contain 'group's. Please note that as of now, the --- parser will return a simple list of addresses; the grouping --- information is lost. - -obs_addr_list :: Stream s m Char => ParsecT s u m [NameAddr] -obs_addr_list = do r1 <- many1 (try (do r <- maybeOption address - optional cfws - _ <- char ',' - optional cfws - return r)) - r2 <- maybeOption address - return (concat (catMaybes (r1 ++ [r2]))) - "obsolete syntax for a list of addresses" - - --- * Obsolete header fields (section 4.5) - -obs_fields :: Stream s m Char => ParsecT s u m [Field] -obs_fields = many $ 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 - <|> do { optional cfws; return [] } - ) - - --- ** Obsolete identification fields (section 4.5.4) - --- |Parse a 'message_id' header line but allow for the obsolete --- folding syntax. - -obs_message_id :: Stream s m Char => ParsecT s u m String -obs_message_id = obs_header "Message-ID" msg_id - --- |Parse an 'in_reply_to' header line but allow for the obsolete --- folding and the obsolete phrase syntax. - -obs_in_reply_to :: Stream s m Char => ParsecT s u m [String] -obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {_ <- phrase; return [] } - <|> msg_id - ) - return (filter (/=[]) r)) - --- |Parse a 'references' header line but allow for the obsolete --- folding and the obsolete phrase syntax. - -obs_references :: Stream s m Char => ParsecT s u m [String] -obs_references = obs_header "References" (do r <- many ( do { _ <- phrase; return [] } - <|> msg_id - ) - return (filter (/=[]) r)) - --- |Parses the \"left part\" of a message ID, but allows the obsolete --- syntax, which is identical to a 'local_part'. - -obs_id_left :: Stream s m Char => ParsecT s u m String -obs_id_left = local_part "left part of an message ID" - --- |Parses the \"right part\" of a message ID, but allows the obsolete --- syntax, which is identical to a 'domain'. - -obs_id_right :: Stream s m Char => ParsecT s u m String -obs_id_right = domain "right part of an message ID" - - - --- ** Obsolete informational fields (section 4.5.5) - --- |Parse a 'subject' header line but allow for the obsolete --- folding syntax. - -obs_subject :: Stream s m Char => ParsecT s u m String -obs_subject = obs_header "Subject" unstructured - --- |Parse a 'comments' header line but allow for the obsolete --- folding syntax. - -obs_comments :: Stream s m Char => ParsecT s u m String -obs_comments = obs_header "Comments" unstructured - --- |Parse a 'keywords' header line but allow for the obsolete --- folding syntax. Also, this parser accepts 'obs_phrase_list'. - -obs_keywords :: Stream s m Char => ParsecT s u m [String] -obs_keywords = obs_header "Keywords" obs_phrase_list - - --- ** Obsolete resent fields (section 4.5.6) - --- |Parse a 'resent_from' header line but allow for the obsolete --- folding syntax. - -obs_resent_from :: Stream s m Char => ParsecT s u m [NameAddr] -obs_resent_from = obs_header "Resent-From" mailbox_list - --- |Parse a 'resent_sender' header line but allow for the obsolete --- folding syntax. - -obs_resent_send :: Stream s m Char => ParsecT s u m NameAddr -obs_resent_send = obs_header "Resent-Sender" mailbox - --- |Parse a 'resent_date' header line but allow for the obsolete --- folding syntax. - -obs_resent_date :: Stream s m Char => ParsecT s u m 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 - <|> do { optional cfws; return [] } - ) - --- |Parse a 'resent_msg_id' header line but allow for the obsolete --- folding syntax. - -obs_resent_mid :: Stream s m Char => ParsecT s u m String -obs_resent_mid = obs_header "Resent-Message-ID" msg_id - --- |Parse a @Resent-Reply-To@ header line but allow for the --- obsolete folding syntax. - -obs_resent_reply :: Stream s m Char => ParsecT s u m [NameAddr] -obs_resent_reply = obs_header "Resent-Reply-To" address_list - - --- ** Obsolete trace fields (section 4.5.7) - -obs_return :: Stream s m Char => ParsecT s u m String -obs_return = obs_header "Return-Path" path - -obs_received :: Stream s m Char => ParsecT s u m [(String, String)] -obs_received = obs_header "Received" name_val_list - --- |Match 'obs_angle_addr'. - -obs_path :: Stream s m Char => ParsecT s u m String -obs_path = obs_angle_addr - --- |This parser is identical to 'optional_field' but allows the more --- liberal line-folding syntax between the \"field_name\" and the \"field --- text\". - -obs_optional :: Stream s m Char => ParsecT s u m (String,String) -obs_optional = do n <- field_name - _ <- many wsp - _ <- char ':' - b <- unstructured - _ <- crlf - return (n,b) - "optional (unspecified) header line" +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 "" + +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" diff --git a/test/spec.hs b/test/spec.hs --- a/test/spec.hs +++ b/test/spec.hs @@ -9,7 +9,7 @@ import Text.Parsec.String ( Parser ) parseTest :: Parser a -> String -> IO a -parseTest p input = case parse (do { r <- p; eof; return r }) (show input) input of +parseTest p input = case parse (p <* eof) (show input) input of Left err -> fail ("parse error at " ++ show err) Right r -> return r