diff --git a/Text/ParserCombinators/Parsec/Rfc2234.hs b/Text/ParserCombinators/Parsec/Rfc2234.hs deleted file mode 100644 --- a/Text/ParserCombinators/Parsec/Rfc2234.hs +++ /dev/null @@ -1,187 +0,0 @@ -{- | - Module : Text.ParserCombinators.Parsec.Rfc2234 - Copyright : (c) 2013 Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - This module provides parsers for the grammar defined in - RFC2234, \"Augmented BNF for Syntax Specifications: - ABNF\", . The - terminal called @char@ in the RFC is called 'character' - here to avoid conflicts with Parsec's 'char' function. - -} - -module Text.ParserCombinators.Parsec.Rfc2234 where - -import Text.ParserCombinators.Parsec -import Data.Char ( toUpper, chr, ord ) -import Control.Monad ( liftM2 ) - --- Customize hlint ... -{-# ANN module "HLint: ignore Use camelCase" #-} - ----------------------------------------------------------------------- --- * Parser Combinators ----------------------------------------------------------------------- - --- |Case-insensitive variant of Parsec's 'char' function. - -caseChar :: Char -> CharParser st Char -caseChar c = satisfy (\x -> toUpper x == toUpper c) - --- |Case-insensitive variant of Parsec's 'string' function. - -caseString :: String -> CharParser st () -caseString cs = mapM_ caseChar cs cs - --- |Match a parser at least @n@ times. - -manyN :: Int -> GenParser a b c -> GenParser a b [c] -manyN n p - | n <= 0 = return [] - | otherwise = liftM2 (++) (count n p) (many p) - --- |Match a parser at least @n@ times, but no more than @m@ times. - -manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c] -manyNtoM n m p - | n < 0 = return [] - | n > m = return [] - | n == m = count n p - | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m])) - | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p) - --- |Helper function to generate 'Parser'-based instances for --- the 'Read' class. - -parsec2read :: Parser a -> String -> [(a, String)] -parsec2read f x = either (error . show) id (parse f' "" x) - where - f' = do { a <- f; res <- getInput; return [(a,res)] } - - ----------------------------------------------------------------------- --- * Primitive Parsers ----------------------------------------------------------------------- - --- |Match any character of the alphabet. - -alpha :: CharParser st Char -alpha = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z'])) - "alphabetic character" - --- |Match either \"1\" or \"0\". - -bit :: CharParser st Char -bit = oneOf "01" "bit ('0' or '1')" - --- |Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is). - -character :: CharParser st Char -character = satisfy (\c -> (c >= chr 1) && (c <= chr 127)) - "7-bit character excluding NUL" - --- |Match the carriage return character @\\r@. - -cr :: CharParser st Char -cr = char '\r' "carriage return" - --- |Match returns the linefeed character @\\n@. - -lf :: CharParser st Char -lf = char '\n' "linefeed" - --- |Match the Internet newline @\\r\\n@. - -crlf :: CharParser st String -crlf = do c <- cr - l <- lf - return [c,l] - "carriage return followed by linefeed" - --- |Match any US-ASCII control character. That is --- any character with a decimal value in the range of [0..31,127]. - -ctl :: CharParser st Char -ctl = satisfy (\c -> ord c `elem` ([0..31] ++ [127])) - "control character" - --- |Match the double quote character \"@\"@\". - -dquote :: CharParser st Char -dquote = char (chr 34) "double quote" - --- |Match any character that is valid in a hexadecimal number; --- [\'0\'..\'9\'] and [\'A\'..\'F\',\'a\'..\'f\'] that is. - -hexdig :: CharParser st Char -hexdig = hexDigit "hexadecimal digit" - --- |Match the tab (\"@\\t@\") character. - -htab :: CharParser st Char -htab = char '\t' "horizontal tab" - --- |Match \"linear white-space\". That is any number of consecutive --- 'wsp', optionally followed by a 'crlf' and (at least) one more --- 'wsp'. - -lwsp :: CharParser st String -lwsp = do r <- choice - [ many1 wsp - , try (liftM2 (++) crlf (many1 wsp)) - ] - rs <- option [] lwsp - return (r ++ rs) - "linear white-space" - --- |Match /any/ character. -octet :: CharParser st Char -octet = anyChar "any 8-bit character" - --- |Match the space. - -sp :: CharParser st Char -sp = char ' ' "space" - --- |Match any printable ASCII character. (The \"v\" stands for --- \"visible\".) That is any character in the decimal range of --- [33..126]. - -vchar :: CharParser st Char -vchar = satisfy (\c -> (c >= chr 33) && (c <= chr 126)) - "printable character" - --- |Match either 'sp' or 'htab'. - -wsp :: CharParser st Char -wsp = sp <|> htab "white-space" - - --- ** Useful additions - --- |Match a \"quoted pair\". Any characters (excluding CR and --- LF) may be quoted. - -quoted_pair :: CharParser st String -quoted_pair = do _ <- char '\\' - r <- noneOf "\r\n" - return ['\\',r] - "quoted pair" - --- |Match a quoted string. The specials \"@\\@\" and --- \"@\"@\" must be escaped inside a quoted string; CR and --- LF are not allowed at all. - -quoted_string :: CharParser st String -quoted_string = do _ <- dquote - r <- many qcont - _ <- dquote - return ("\"" ++ concat r ++ "\"") - "quoted string" - where - qtext = noneOf "\\\"\r\n" - qcont = many1 qtext <|> quoted_pair diff --git a/Text/ParserCombinators/Parsec/Rfc2821.hs b/Text/ParserCombinators/Parsec/Rfc2821.hs deleted file mode 100644 --- a/Text/ParserCombinators/Parsec/Rfc2821.hs +++ /dev/null @@ -1,520 +0,0 @@ -{- | - Module : Text.ParserCombinators.Parsec.Rfc2821 - Copyright : (c) 2013 Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - This module exports parser combinators for the grammar - described in RFC2821, \"Simple Mail Transfer Protocol\", - . --} - -module Text.ParserCombinators.Parsec.Rfc2821 where - -import Control.Exception ( assert ) -import Control.Monad.State -import Text.ParserCombinators.Parsec -import Data.List ( intercalate ) -import Data.Char ( toLower ) -import Text.ParserCombinators.Parsec.Rfc2234 - --- Customize hlint ... -{-# ANN module "HLint: ignore Use camelCase" #-} - ----------------------------------------------------------------------- --- * ESMTP State Machine ----------------------------------------------------------------------- - -data SessionState - = Unknown - | HaveHelo - | HaveMailFrom - | HaveRcptTo - | HaveData - | HaveQuit - deriving (Enum, Bounded, Eq, Ord, Show) - -data Event - = Greeting -- ^ reserved for the user - | SayHelo String - | SayHeloAgain String - | SayEhlo String - | SayEhloAgain String - | SetMailFrom Mailbox - | AddRcptTo Mailbox - | StartData - | Deliver -- ^ reserved for the user - | NeedHeloFirst - | NeedMailFromFirst - | NeedRcptToFirst - | NotImplemened - -- ^ 'Turn', 'Send', 'Soml', 'Saml', 'Vrfy', and 'Expn'. - | ResetState - | SayOK - -- ^ Triggered in case of 'Noop' or when 'Rset' is - -- used before we even have a state. - | SeeksHelp String - -- ^ The parameter may be @[]@. - | Shutdown - | SyntaxErrorIn String - | Unrecognized String - deriving (Eq, Show) - -type SmtpdFSM = Control.Monad.State.State SessionState Event - --- |Parse a line of SMTP dialogue and run 'handleSmtpCmd' to --- determine the 'Event'. In case of syntax errors, --- 'SyntaxErrorIn' or 'Unrecognized' will be returned. --- Inputs must be terminated with 'crlf'. See 'fixCRLF'. - -smtpdFSM :: String -> SmtpdFSM -smtpdFSM str = either - (\_ -> return (Unrecognized str)) - handleSmtpCmd - (parse smtpCmd "" str) - --- |For those who want to parse the 'SmtpCmd' themselves. --- Calling this function in 'HaveQuit' or 'HaveData' will --- fail an assertion. If 'assert' is disabled, it will --- return respectively 'Shutdown' and 'StartData' again. - -handleSmtpCmd :: SmtpCmd -> SmtpdFSM -handleSmtpCmd cmd = get >>= \st -> match st cmd - where - match :: SessionState -> SmtpCmd -> SmtpdFSM - match HaveQuit _ = assert False (event Shutdown) - match HaveData _ = assert False (trans (HaveData, StartData)) - match _ (WrongArg c _) = event (SyntaxErrorIn c) - match _ Quit = trans (HaveQuit, Shutdown) - match _ Noop = event SayOK - match _ Turn = event NotImplemened - - match _ (Send _) = event NotImplemened - match _ (Soml _) = event NotImplemened - match _ (Saml _) = event NotImplemened - match _ (Vrfy _) = event NotImplemened - match _ (Expn _) = event NotImplemened - match _ (Help x) = event (SeeksHelp x) - - match Unknown Rset = event SayOK - match HaveHelo Rset = event SayOK - match _ Rset = trans (HaveHelo, ResetState) - - match Unknown (Helo x) = trans (HaveHelo, SayHelo x) - match _ (Helo x) = trans (HaveHelo, SayHeloAgain x) - match Unknown (Ehlo x) = trans (HaveHelo, SayEhlo x) - match _ (Ehlo x) = trans (HaveHelo, SayEhloAgain x) - - match Unknown (MailFrom _) = event NeedHeloFirst - match _ (MailFrom x) = trans (HaveMailFrom, SetMailFrom x) - - match Unknown (RcptTo _) = event NeedHeloFirst - match HaveHelo (RcptTo _) = event NeedMailFromFirst - match _ (RcptTo x) = trans (HaveRcptTo, AddRcptTo x) - - match Unknown Data = event NeedHeloFirst - match HaveHelo Data = event NeedMailFromFirst - match HaveMailFrom Data = event NeedRcptToFirst - match HaveRcptTo Data = trans (HaveData, StartData) - - event :: Event -> SmtpdFSM - event = return - - trans :: (SessionState, Event) -> SmtpdFSM - trans (st,e) = put st >> event e - - ----------------------------------------------------------------------- --- * Data Types for SMTP Commands ----------------------------------------------------------------------- - --- |The 'smtpCmd' parser will create this data type from a --- string. Note that /all/ command parsers expect their --- input to be terminated with 'crlf'. - -data SmtpCmd - = Helo String - | Ehlo String - | MailFrom Mailbox -- ^ Might be 'nullPath'. - | RcptTo Mailbox -- ^ Might be 'postmaster'. - | Data - | Rset - | Send Mailbox - | Soml Mailbox - | Saml Mailbox - | Vrfy String - | Expn String - | Help String -- ^ Might be @[]@. - | Noop -- ^ Optional argument ignored. - | Quit - | Turn - | WrongArg String ParseError - -- ^ When a valid command has been recognized, but the - -- argument parser fails, then this type will be - -- returned. The 'String' contains the name of the - -- command (in all upper-case) and the 'ParseError' - -- is, obviously, the error description. - -instance Show SmtpCmd where - show (Helo str) = "HELO " ++ str - show (Ehlo str) = "EHLO " ++ str - show (MailFrom mbox) = "MAIL FROM:" ++ show mbox - show (RcptTo mbox) = "RCPT TO:" ++ show mbox - show (Data) = "DATA" - show (Rset) = "RSET" - show (Send mbox) = "SEND " ++ show mbox - show (Soml mbox) = "SOML " ++ show mbox - show (Saml mbox) = "SAML " ++ show mbox - show (Vrfy str) = "VRFY " ++ str - show (Expn str) = "EXPN " ++ str - show (Noop) = "NOOP" - show (Quit) = "QUIT" - show (Turn) = "TURN" - show (Help t) - | null t = "HELP" - | otherwise = "HELP " ++ t - show (WrongArg str _) = - "Syntax error in argument of " ++ str ++ "." - --- |The most general e-mail address has the form: --- @\<[\@route,...:]user\@domain\>@. This type, too, --- supports 'show' and 'read'. Note that a \"shown\" address --- is /always/ enclosed in angular brackets. When comparing --- two mailboxes for equality, the hostname is case-insensitive. - -data Mailbox = Mailbox [String] String String - -instance Eq Mailbox where - lhs == rhs = norm lhs == norm rhs - where - norm (Mailbox rt lp hp) = (rt, lp, map toLower hp) - -instance Show Mailbox where - show (Mailbox [] [] []) = "<>" - show (Mailbox [] "postmaster" []) = "" - 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 SMTP Replies ----------------------------------------------------------------------- - --- |An SMTP reply is a three-digit return code plus some waste of --- bandwidth called \"comments\". This is what the list of strings is --- for; one string per line in the reply. 'show' will append an --- \"@\\r\\n@\" end-of-line marker to each entry in that list, so that --- the resulting string is ready to be sent back to the peer. For --- example: --- --- >>> show $ Reply (Code Success MailSystem 0) ["worked", "like", "a charm" ] --- "250-worked\r\n250-like\r\n250 a charm\r\n" --- --- If the message is an empty list @[]@, a default text will be constructed: --- --- >>> show $ Reply (Code Success MailSystem 0) [] --- "250 Success in category MailSystem\r\n" - -data SmtpReply = Reply SmtpCode [String] - -data SmtpCode = Code SuccessCode Category Int - -data SuccessCode - = Unused0 - | PreliminarySuccess - | Success - | IntermediateSuccess - | TransientFailure - | PermanentFailure - deriving (Enum, Bounded, Eq, Ord, Show) - -data Category - = Syntax - | Information - | Connection - | Unspecified3 - | Unspecified4 - | MailSystem - deriving (Enum, Bounded, Eq, Ord, Show) - -instance Show SmtpReply where - show (Reply c@(Code suc cat _) []) = - let msg = show suc ++ " in category " ++ show cat - in - show $ Reply c [msg] - - show (Reply code msg) = - let prefixCon = show code ++ "-" - prefixEnd = show code ++ " " - fmt p l = p ++ l ++ "\r\n" - (x:xs) = reverse msg - msgCon = map (fmt prefixCon) xs - msgEnd = fmt prefixEnd x - msg' = reverse (msgEnd:msgCon) - in - concat msg' - -instance Show SmtpCode where - show (Code suc cat n) = - assert (n >= 0 && n <= 9) $ - (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n - --- |Construct a 'Reply'. Fails 'assert' if invalid numbers --- are given. - -reply :: Int -> Int -> Int -> [String] -> SmtpReply -reply suc c n msg = - assert (suc >= 0 && suc <= 5) $ - assert (c >= 0 && c <= 5) $ - assert (n >= 0 && n <= 9) $ - Reply (Code (toEnum suc) (toEnum c) n) msg - --- |A reply constitutes \"success\" if the status code is --- any of 'PreliminarySuccess', 'Success', or --- 'IntermediateSuccess'. - -isSuccess :: SmtpReply -> Bool -isSuccess (Reply (Code PreliminarySuccess _ _) _) = True -isSuccess (Reply (Code Success _ _) _) = True -isSuccess (Reply (Code IntermediateSuccess _ _) _) = True -isSuccess _ = False - --- |A reply constitutes \"failure\" if the status code is --- either 'PermanentFailure' or 'TransientFailure'. - -isFailure :: SmtpReply -> Bool -isFailure (Reply (Code PermanentFailure _ _) _) = True -isFailure (Reply (Code TransientFailure _ _) _) = True -isFailure _ = False - --- |The replies @221@ and @421@ signify 'Shutdown'. - -isShutdown :: SmtpReply -> Bool -isShutdown (Reply (Code Success Connection 1) _) = True -isShutdown (Reply (Code TransientFailure Connection 1) _) = True -isShutdown _ = False - ----------------------------------------------------------------------- --- * Command Parsers ----------------------------------------------------------------------- - --- |The SMTP parsers defined here correspond to the commands --- specified in RFC2821, so I won't document them --- individually. - -type SmtpParser st = CharParser st SmtpCmd - --- |This parser recognizes any of the SMTP commands defined --- below. Note that /all/ command parsers expect their input --- to be terminated with 'crlf'. - -smtpCmd :: SmtpParser st -smtpCmd = choice - [ smtpData, rset, noop, quit, turn - , helo, mail, rcpt, send, soml, saml - , vrfy, expn, help, ehlo - ] - --- |The parser name \"data\" was taken. -smtpData :: SmtpParser st -rset, quit, turn, helo, ehlo, mail :: SmtpParser st -rcpt, send, soml, saml, vrfy, expn :: SmtpParser st -help :: SmtpParser st - --- |May have an optional 'word' argument, but it is ignored. -noop :: SmtpParser st - -smtpData = mkCmd0 "DATA" Data -rset = mkCmd0 "RSET" Rset -quit = mkCmd0 "QUIT" Quit -turn = mkCmd0 "TURN" Turn -helo = mkCmd1 "HELO" Helo domain -ehlo = mkCmd1 "EHLO" Ehlo domain -mail = mkCmd1 "MAIL" MailFrom from_path -rcpt = mkCmd1 "RCPT" RcptTo to_path -send = mkCmd1 "SEND" Send from_path -soml = mkCmd1 "SOML" Soml from_path -saml = mkCmd1 "SAML" Saml from_path -vrfy = mkCmd1 "VRFY" Vrfy word -expn = mkCmd1 "EXPN" Expn word - -help = try (mkCmd0 "HELP" (Help [])) <|> - mkCmd1 "HELP" Help (option [] word) - -noop = try (mkCmd0 "NOOP" Noop) <|> - mkCmd1 "NOOP" (const Noop) (option [] word) - - ----------------------------------------------------------------------- --- * Argument Parsers ----------------------------------------------------------------------- - -from_path :: CharParser st Mailbox -from_path = do - caseString "from:" - (try (string "<>" >> return nullPath) <|> path) - "from-path" - -to_path :: CharParser st Mailbox -to_path = do - caseString "to:" - (try (caseString "" >> return postmaster) - <|> path) "to-path" - -path :: CharParser st Mailbox -path = between (char '<') (char '>') (p "path") - where - p = do - r1 <- option [] (a_d_l >>= \r -> char ':' >> return r) - (Mailbox _ l d) <- mailbox - return (Mailbox r1 l d) - -mailbox :: CharParser st Mailbox -mailbox = p "mailbox" - where - p = do - r1 <- local_part - _ <- char '@' - r2 <- domain - return (Mailbox [] r1 r2) - -local_part :: CharParser st String -local_part = (dot_string <|> quoted_string) "local-part" - -domain :: CharParser st String -domain = choice - [ tokenList subdomain '.' "domain" - , address_literal "address literal" - ] - -a_d_l :: CharParser st [String] -a_d_l = sepBy1 at_domain (char ',') "route-list" - -at_domain :: CharParser st String -at_domain = (char '@' >> domain) "at-domain" - --- |/TODO/: Add IPv6 address and general literals -address_literal :: CharParser st String -address_literal = ipv4_literal "IPv4 address literal" - -ipv4_literal :: CharParser st String -ipv4_literal = do - rs <- between (char '[') (char ']') ipv4addr - return ('[': reverse (']': reverse rs)) - -ipv4addr :: CharParser st String -ipv4addr = p "IPv4 address literal" - where - p = do - r1 <- snum - r2 <- char '.' >> snum - r3 <- char '.' >> snum - r4 <- char '.' >> snum - return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4) - -subdomain :: CharParser st String -subdomain = p "domain name" - where - p = do - r <- many1 (alpha <|> digit <|> char '-') - if last r == '-' - then fail "subdomain must not end with hyphen" - else return r - -dot_string :: CharParser st String -dot_string = tokenList atom '.' "dot_string" - -atom :: CharParser a String -atom = many1 atext "atom" - where - atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" - -snum :: CharParser st String -snum = do - r <- manyNtoM 1 3 digit - if (read r :: Int) > 255 - then fail "IP address parts must be 0 <= x <= 255" - else return r - -number :: CharParser st String -number = many1 digit - --- |This is a useful addition: The parser accepts an 'atom' --- or a 'quoted_string'. - -word :: CharParser st String -word = (atom <|> fmap show quoted_string) - "word or quoted-string" - - ----------------------------------------------------------------------- --- * Helper Functions ----------------------------------------------------------------------- - --- |Make the string 'crlf' terminated no matter what. --- \'@\\n@\' is expanded, otherwise 'crlf' is appended. Note --- that if the string was terminated incorrectly before, it --- still is. This function is useful when reading input with --- 'System.IO.hGetLine' which removes the end-of-line --- delimiter. - -fixCRLF :: String -> String -fixCRLF ('\r' :'\n':[]) = fixCRLF [] -fixCRLF ( x :'\n':[]) = x : fixCRLF [] -fixCRLF ( x : xs ) = x : fixCRLF xs -fixCRLF [ ] = "\r\n" - --- |Construct a parser for a command without arguments. --- Expects 'crlf'! - -mkCmd0 :: String -> a -> CharParser st a -mkCmd0 str cons = (do - try (caseString str) - _ <- skipMany wsp >> crlf - return cons) str - --- |Construct a parser for a command with an argument, which --- the given parser will handle. The result of the argument --- parser will be applied to the type constructor before it --- is returned. Expects 'crlf'! - -mkCmd1 :: String -> (a -> SmtpCmd) -> CharParser st a - -> CharParser st SmtpCmd -mkCmd1 str cons p = do - try (caseString str) - _ <- wsp - input <- getInput - st <- getState - let eol = skipMany wsp >> crlf - p' = between (many wsp) eol p str - r = runParser p' st "" input - case r of - Left e -> return (WrongArg str e) - Right a -> return (cons a) - --- @tokenList p '.'@ will parse a token of the form --- \"@p.p@\", or \"@p.p.p@\", and so on. Used in 'domain' --- and 'dot_string', for example. - -tokenList :: CharParser st String -> Char - -> CharParser st String -tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c)) diff --git a/Text/ParserCombinators/Parsec/Rfc2822.hs b/Text/ParserCombinators/Parsec/Rfc2822.hs deleted file mode 100644 --- a/Text/ParserCombinators/Parsec/Rfc2822.hs +++ /dev/null @@ -1,1402 +0,0 @@ -{- | - Module : Text.ParserCombinators.Parsec.Rfc2822 - Copyright : (c) 2013 Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - This module provides parsers for the grammar defined in - RFC2822, \"Internet Message Format\", - . --} - -module Text.ParserCombinators.Parsec.Rfc2822 where - -import System.Time -import Data.Char ( ord ) -import Data.List ( intercalate ) -import Data.Maybe ( catMaybes ) -import Control.Monad ( liftM ) -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string ) - --- Customize hlint ... -{-# ANN module "HLint: ignore Use camelCase" #-} - --- * Useful parser combinators - --- |Return @Nothing@ if the given parser doesn't match. This --- combinator is included in the latest parsec distribution as --- @optionMaybe@, but ghc-6.6.1 apparently doesn't have it. - -maybeOption :: GenParser tok st a -> GenParser tok st (Maybe a) -maybeOption p = option Nothing (liftM Just p) - --- |@unfold@ @=@ @between (optional cfws) (optional cfws)@ - -unfold :: CharParser a b -> CharParser a b -unfold = between (optional cfws) (optional cfws) - --- |Construct a parser for a message header line from the --- header's name and a parser for the body. - -header :: String -> CharParser a b -> CharParser a b -header n p = let nameString = caseString (n ++ ":") - in - between nameString crlf p (n ++ " header line") - --- |Like 'header', but allows the obsolete white-space rules. - -obs_header :: String -> CharParser a b -> CharParser a b -obs_header n p = let nameString = caseString n >> many wsp >> char ':' - in - between nameString crlf p ("obsolete " ++ n ++ " header line") - - --- ** Primitive Tokens (section 3.2.1) - --- |Match any US-ASCII non-whitespace control character. - -no_ws_ctl :: CharParser a Char -no_ws_ctl = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127])) - "US-ASCII non-whitespace control character" - --- |Match any US-ASCII character except for @\r@, @\n@. - -text :: CharParser a Char -text = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127])) - "US-ASCII character (excluding CR and LF)" - --- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@. - -specials :: CharParser a Char -specials = oneOf "()<>[]:;@,.\\\"" "one of ()<>[]:;@,.\\\"" - - --- ** Quoted characters (section 3.2.2) - --- |Match a \"quoted pair\". All characters matched by 'text' may be --- quoted. Note that the parsers returns /both/ characters, the --- backslash and the actual content. - -quoted_pair :: CharParser a String -quoted_pair = try obs_qp <|> do { _ <- char '\\'; r <- text; return ['\\',r] } - "quoted pair" - - --- ** Folding white space and comments (section 3.2.3) - --- |Match \"folding whitespace\". That is any combination of 'wsp' and --- 'crlf' followed by 'wsp'. - -fws :: CharParser a String -fws = do r <- many1 $ choice [ blanks, linebreak] - return (concat r) - where - blanks = many1 wsp - linebreak = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) } - --- |Match any non-whitespace, non-control character except for \"@(@\", --- \"@)@\", and \"@\\@\". This is used to describe the legal content of --- 'comment's. --- --- /Note/: This parser accepts 8-bit characters, even though this is --- not legal according to the RFC. Unfortunately, 8-bit content in --- comments has become fairly common in the real world, so we'll just --- accept the fact. - -ctext :: CharParser a Char -ctext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255])) - "any regular character (excluding '(', ')', and '\\')" - --- |Match a \"comments\". That is any combination of 'ctext', --- 'quoted_pair's, and 'fws' between brackets. Comments may nest. - -comment :: CharParser a String -comment = do _ <- char '(' - r1 <- many ccontent - r2 <- option [] fws - _ <- char ')' - return ("(" ++ concat r1 ++ r2 ++ ")") - "comment" - where - ccontent = try $ do r1 <- option [] fws - r2 <- choice [many1 ctext, quoted_pair, comment] - return (r1 ++ r2) - --- |Match any combination of 'fws' and 'comments'. - -cfws :: CharParser a String -cfws = do r <- many1 $ choice [ fws, comment ] - return (concat r) - --- ** Atom (section 3.2.4) - --- |Match any US-ASCII character except for control characters, --- 'specials', or space. 'atom' and 'dot_atom' are made up of this. - -atext :: CharParser a Char -atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" - "US-ASCII character (excluding controls, space, and specials)" - --- |Match one or more 'atext' characters and skip any preceeding or --- trailing 'cfws'. - -atom :: CharParser a String -atom = unfold (many1 atext "atom") - --- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'. - -dot_atom :: CharParser a String -dot_atom = unfold (dot_atom_text "dot atom") - --- |Match two or more 'atext's interspersed by dots. - -dot_atom_text :: CharParser a String -dot_atom_text = fmap (intercalate ".") (sepBy1 (many1 atext) (char '.')) - "dot atom content" - - --- ** Quoted strings (section 3.2.5) - --- |Match any non-whitespace, non-control US-ASCII character except --- for \"@\\@\" and \"@\"@\". - -qtext :: CharParser a Char -qtext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33] ++ [35..91] ++ [93..126])) - "US-ASCII character (excluding '\\', and '\"')" - --- |Match either 'qtext' or 'quoted_pair'. - -qcontent :: CharParser a String -qcontent = many1 qtext <|> quoted_pair - "quoted string content" - --- |Match any number of 'qcontent' between double quotes. Any 'cfws' --- preceeding or following the \"atom\" is skipped automatically. - -quoted_string :: CharParser a String -quoted_string = unfold (do _ <- dquote - r1 <- many (do r1 <- option [] fws - r2 <- qcontent - return (r1 ++ r2)) - r2 <- option [] fws - _ <- dquote - return ("\"" ++ concat r1 ++ r2 ++ "\"")) - "quoted string" - - --- * Miscellaneous tokens (section 3.2.6) - --- |Match either 'atom' or 'quoted_string'. - -word :: CharParser a String -word = unfold (atom <|> quoted_string) "word" - --- |Match either one or more 'word's or an 'obs_phrase'. - -phrase :: CharParser a [String] -phrase = {- many1 word "phrase" <|> -} obs_phrase - --- |Match any non-whitespace, non-control US-ASCII character except --- for \"@\\@\" and \"@\"@\". - -utext :: CharParser a Char -utext = no_ws_ctl <|> satisfy (\c -> ord c `elem` [33..126]) - "regular US-ASCII character (excluding '\\', and '\"')" - --- |Match any number of 'utext' tokens. --- --- \"Unstructured text\" is used in free text fields such as 'subject'. --- Please note that any comments or whitespace that prefaces or --- follows the actual 'utext' is /included/ in the returned string. - -unstructured :: CharParser a String -unstructured = do r1 <- option [] fws - r2 <- many (do r3 <- utext - r4 <- option [] fws - return (r3 : r4)) - return (r1 ++ concat r2) - "unstructured text" - - --- * Date and Time Specification (section 3.3) - --- |Parse a date and time specification of the form --- --- > Thu, 19 Dec 2002 20:35:46 +0200 --- --- where the weekday specification \"@Thu,@\" is optional. The parser --- returns a 'CalendarTime', which is set to the appropriate values. --- Note, though, that not all fields of 'CalendarTime' will --- necessarily be set correctly! Obviously, when no weekday has been --- provided, the parser will set this field to 'Monday' - regardless --- of whether the day actually is a monday or not. Similarly, the day --- of the year will always be returned as @0@. The timezone name will --- always be empty: @\"\"@. --- --- Nor will the 'date_time' parser perform /any/ consistency checking. --- It will accept --- --- > 40 Apr 2002 13:12 +0100 --- --- as a perfectly valid date. --- --- In order to get all fields set to meaningful values, and in order --- to verify the date's consistency, you will have to feed it into any --- of the conversion routines provided in "System.Time", such as --- 'toClockTime'. (When doing this, keep in mind that most functions --- return /local time/. This will not necessarily be the time you're --- expecting.) - -date_time :: CharParser a CalendarTime -date_time = do wd <- option Monday (try (do wd <- day_of_week - _ <- char ',' - return wd)) - (y,m,d) <- date - _ <- fws - (td,z) <- time - optional cfws - return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False) - "date/time specification" - --- |This parser matches a 'day_name' or an 'obs_day_of_week' (optionally --- wrapped in folding whitespace) and return its 'Day' value. - -day_of_week :: CharParser a Day -day_of_week = try (between (optional fws) (optional fws) day_name "name of a day-of-the-week") - <|> obs_day_of_week - --- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...) --- and return the appropriate 'Day' value. - -day_name :: CharParser a Day -day_name = do { caseString "Mon"; return Monday } - <|> do { try (caseString "Tue"); return Tuesday } - <|> do { caseString "Wed"; return Wednesday } - <|> do { caseString "Thu"; return Thursday } - <|> do { caseString "Fri"; return Friday } - <|> do { try (caseString "Sat"); return Saturday } - <|> do { caseString "Sun"; return Sunday } - "name of a day-of-the-week" - --- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return --- a tripple of the form (Int,Month,Int) - corresponding to --- (year,month,day). - -date :: CharParser a (Int,Month,Int) -date = do d <- day - m <- month - y <- year - return (y,m,d) - "date specification" - --- |This parser will match a four digit number and return its integer --- value. No range checking is performed. - -year :: CharParser a Int -year = do y <- manyN 4 digit - return (read y :: Int) - "year" - --- |This parser will match a 'month_name', optionally wrapped in --- folding whitespace, or an 'obs_month' and return its 'Month' --- value. - -month :: CharParser a Month -month = try (between (optional fws) (optional fws) month_name "month name") - <|> obs_month - - --- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...) --- and return the appropriate 'Month' value. - -month_name :: CharParser a Month -month_name = do { try (caseString "Jan"); return January } - <|> do { caseString "Feb"; return February } - <|> do { try (caseString "Mar"); return March } - <|> do { try (caseString "Apr"); return April } - <|> do { caseString "May"; return May } - <|> do { try (caseString "Jun"); return June } - <|> do { caseString "Jul"; return July } - <|> do { caseString "Aug"; return August } - <|> do { caseString "Sep"; return September } - <|> do { caseString "Oct"; return October } - <|> do { caseString "Nov"; return November } - <|> do { caseString "Dec"; return December } - "month name" - --- Internal helper function: match a 1 or 2-digit number (day of month). - -day_of_month :: CharParser a Int -day_of_month = fmap read (manyNtoM 1 2 digit) - --- |Match a 1 or 2-digit number (day of month), recognizing both --- standard and obsolete folding syntax. - -day :: CharParser a Int -day = try obs_day <|> day_of_month "day" - --- |This parser will match a 'time_of_day' specification followed by a --- 'zone'. It returns the tuple (TimeDiff,Int) corresponding to the --- return values of either parser. - -time :: CharParser a (TimeDiff,Int) -time = do t <- time_of_day - _ <- fws - z <- zone - return (t,z) - "time and zone specification" - --- |This parser will match a time-of-day specification of \"@hh:mm@\" or --- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'. - -time_of_day :: CharParser a TimeDiff -time_of_day = do h <- hour - _ <- char ':' - m <- minute - s <- option 0 (do { _ <- char ':'; second } ) - return (TimeDiff 0 0 0 h m s 0) - "time specification" - --- |This parser will match a two-digit number and return its integer --- value. No range checking is performed. - -hour :: CharParser a Int -hour = do r <- count 2 digit - return (read r :: Int) - "hour" - --- |This parser will match a two-digit number and return its integer --- value. No range checking is performed. - -minute :: CharParser a Int -minute = do r <- count 2 digit - return (read r :: Int) - "minute" - --- |This parser will match a two-digit number and return its integer --- value. No range checking takes place. - -second :: CharParser a Int -second = do r <- count 2 digit - return (read r :: Int) - "second" - --- |This parser will match a timezone specification of the form --- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in --- seconds as an integer. 'obs_zone' is matched as well. - -zone :: CharParser a Int -zone = ( do _ <- char '+' - h <- hour - m <- minute - return (((h*60)+m)*60) - <|> do _ <- char '-' - h <- hour - m <- minute - return (-((h*60)+m)*60) - "time zone" - ) - <|> obs_zone - - --- * Address Specification (section 3.4) - --- |A NameAddr is composed of an optional realname a mandatory --- e-mail 'address'. - -data NameAddr = NameAddr { nameAddr_name :: Maybe String - , nameAddr_addr :: String - } - deriving (Show,Eq) - --- |Parse a single 'mailbox' or an address 'group' and return the --- address(es). - -address :: CharParser a [NameAddr] -address = try (do { r <- mailbox; return [r] }) <|> group - "address" - --- |Parse a 'name_addr' or an 'addr_spec' and return the --- address. - -mailbox :: CharParser a NameAddr -mailbox = try name_addr <|> fmap (NameAddr Nothing) addr_spec - "mailbox" - --- |Parse an 'angle_addr', optionally prefaced with a 'display_name', --- and return the address. - -name_addr :: CharParser a NameAddr -name_addr = do name <- maybeOption display_name - addr <- angle_addr - return (NameAddr name addr) - "name address" - --- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address. - -angle_addr :: CharParser a String -angle_addr = try (unfold (do _ <- char '<' - r <- addr_spec - _ <- char '>' - return r) - "angle address" - ) - <|> obs_angle_addr - --- |Parse a \"group\" of addresses. That is a 'display_name', followed --- by a colon, optionally followed by a 'mailbox_list', followed by a --- semicolon. The found address(es) are returned - what may be none. --- Here is an example: --- --- >>> parse group "" "my group: user1@example.org, user2@example.org;" --- Right [NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user1@example.org"},NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user2@example.org"}] - -group :: CharParser a [NameAddr] -group = do _ <- display_name - _ <- char ':' - r <- option [] mailbox_list - _ <- unfold $ char ';' - return r - "address group" - --- |Parse and return a 'phrase'. - -display_name :: CharParser a String -display_name = fmap unwords phrase - "display name" - --- |Parse a list of 'mailbox' addresses, every two addresses being --- separated by a comma, and return the list of found address(es). - -mailbox_list :: CharParser a [NameAddr] -mailbox_list = sepBy mailbox (char ',') "mailbox list" - --- |Parse a list of 'address' addresses, every two addresses being --- separated by a comma, and return the list of found address(es). - -address_list :: CharParser a [NameAddr] -address_list = do { r <-sepBy address (char ','); return (concat r) } - "address list" - - --- ** Addr-spec specification (section 3.4.1) - --- |Parse an \"address specification\". That is a 'local_part', followed --- by an \"@\@@\" character, followed by a 'domain'. Return the complete --- address as 'String', ignoring any whitespace or any comments. - -addr_spec :: CharParser a String -addr_spec = do r1 <- local_part - _ <- char '@' - r2 <- domain - return (r1 ++ "@" ++ r2) - "address specification" - --- |Parse and return a \"local part\" of an 'addr_spec'. That is either --- a 'dot_atom' or a 'quoted_string'. - -local_part :: CharParser a String -local_part = try obs_local_part <|> dot_atom <|> quoted_string - "address' local part" - --- |Parse and return a \"domain part\" of an 'addr_spec'. That is either --- a 'dot_atom' or a 'domain_literal'. - -domain :: CharParser a String -domain = try obs_domain <|> dot_atom <|> domain_literal - "address' domain part" - --- |Parse a \"domain literal\". That is a \"@[@\" character, followed by --- any amount of 'dcontent', followed by a terminating \"@]@\" --- character. The complete string is returned verbatim. - -domain_literal :: CharParser a String -domain_literal = unfold (do _ <- char '[' - r <- many (optional fws >> dcontent) - optional fws - _ <- char ']' - return ("[" ++ concat r ++ "]")) - "domain literal" - --- |Parse and return any characters that are legal in a --- 'domain_literal'. That is 'dtext' or a 'quoted_pair'. - -dcontent :: CharParser a String -dcontent = many1 dtext <|> quoted_pair - "domain literal content" - --- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and --- \"@\\@\". - -dtext :: CharParser a Char -dtext = no_ws_ctl - <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94..126])) - "any ASCII character (excluding '[', ']', and '\\')" - - --- * Overall message syntax (section 3.5) - --- |This data type repesents a parsed Internet Message as defined in --- this RFC. It consists of an arbitrary number of header lines, --- represented in the 'Field' data type, and a message body, which may --- be empty. - -data GenericMessage a = Message [Field] a deriving Show -type Message = GenericMessage String - --- |Parse a complete message as defined by this RFC and it broken down --- into the separate header fields and the message body. Header lines, --- which contain syntax errors, will not cause the parser to abort. --- Rather, these headers will appear as 'OptionalField's (which are --- unparsed) in the resulting 'Message'. A message must be really, --- really badly broken for this parser to fail. --- --- This behaviour was chosen because it is impossible to predict what --- the user of this module considers to be a fatal error; --- traditionally, parsers are very forgiving when it comes to Internet --- messages. --- --- If you want to implement a really strict parser, you'll have to put --- the appropriate parser together yourself. You'll find that this is --- rather easy to do. Refer to the 'fields' parser for further details. - -message :: CharParser a Message -message = do f <- fields - b <- option [] (do _ <- crlf; body) - return (Message f b) - --- |A message body is just an unstructured sequence of characters. - -body :: CharParser a String -body = many anyChar - - --- * Field definitions (section 3.6) - --- |This data type represents any of the header fields defined in this --- RFC. Each of the various instances contains with the return value --- of the corresponding parser. - -data Field = OptionalField String String - | From [NameAddr] - | Sender NameAddr - | ReturnPath String - | ReplyTo [NameAddr] - | To [NameAddr] - | Cc [NameAddr] - | Bcc [NameAddr] - | MessageID String - | InReplyTo [String] - | References [String] - | Subject String - | Comments String - | Keywords [[String]] - | Date CalendarTime - | ResentDate CalendarTime - | ResentFrom [NameAddr] - | ResentSender NameAddr - | ResentTo [NameAddr] - | ResentCc [NameAddr] - | ResentBcc [NameAddr] - | ResentMessageID String - | ResentReplyTo [NameAddr] - | Received ([(String,String)], CalendarTime) - | ObsReceived [(String,String)] - deriving (Show) - --- |This parser will parse an arbitrary number of header fields as --- defined in this RFC. For each field, an appropriate 'Field' value --- is created, all of them making up the 'Field' list that this parser --- returns. --- --- If you look at the implementation of this parser, you will find --- that it uses Parsec's 'try' modifier around /all/ of the fields. --- The idea behind this is that fields, which contain syntax errors, --- fall back to the catch-all 'optional_field'. Thus, this parser will --- hardly ever return a syntax error -- what conforms with the idea --- that any message that can possibly be accepted /should/ be. - -fields :: CharParser a [Field] -fields = many ( try (do { r <- from; return (From r) }) - <|> try (do { r <- sender; return (Sender r) }) - <|> try (do { r <- return_path; return (ReturnPath r) }) - <|> try (do { r <- reply_to; return (ReplyTo r) }) - <|> try (do { r <- to; return (To r) }) - <|> try (do { r <- cc; return (Cc r) }) - <|> try (do { r <- bcc; return (Bcc r) }) - <|> try (do { r <- message_id; return (MessageID r) }) - <|> try (do { r <- in_reply_to; return (InReplyTo r) }) - <|> try (do { r <- references; return (References r) }) - <|> try (do { r <- subject; return (Subject r) }) - <|> try (do { r <- comments; return (Comments r) }) - <|> try (do { r <- keywords; return (Keywords r) }) - <|> try (do { r <- orig_date; return (Date r) }) - <|> try (do { r <- resent_date; return (ResentDate r) }) - <|> try (do { r <- resent_from; return (ResentFrom r) }) - <|> try (do { r <- resent_sender; return (ResentSender r) }) - <|> try (do { r <- resent_to; return (ResentTo r) }) - <|> try (do { r <- resent_cc; return (ResentCc r) }) - <|> try (do { r <- resent_bcc; return (ResentBcc r) }) - <|> try (do { r <- resent_msg_id; return (ResentMessageID r) }) - <|> try (do { r <- received; return (Received r) }) - -- catch all - <|> (do { (name,cont) <- optional_field; return (OptionalField name cont) }) - ) - - --- ** The origination date field (section 3.6.1) - --- |Parse a \"@Date:@\" header line and return the date it contains a --- 'CalendarTime'. - -orig_date :: CharParser a CalendarTime -orig_date = header "Date" date_time - - --- ** Originator fields (section 3.6.2) - --- |Parse a \"@From:@\" header line and return the 'mailbox_list' --- address(es) contained in it. - -from :: CharParser a [NameAddr] -from = header "From" mailbox_list - --- |Parse a \"@Sender:@\" header line and return the 'mailbox' address --- contained in it. - -sender :: CharParser a NameAddr -sender = header "Sender" mailbox - --- |Parse a \"@Reply-To:@\" header line and return the 'address_list' --- address(es) contained in it. - -reply_to :: CharParser a [NameAddr] -reply_to = header "Reply-To" address_list - - --- ** Destination address fields (section 3.6.3) - --- |Parse a \"@To:@\" header line and return the 'address_list' --- address(es) contained in it. - -to :: CharParser a [NameAddr] -to = header "To" address_list - --- |Parse a \"@Cc:@\" header line and return the 'address_list' --- address(es) contained in it. - -cc :: CharParser a [NameAddr] -cc = header "Cc" address_list - --- |Parse a \"@Bcc:@\" header line and return the 'address_list' --- address(es) contained in it. - -bcc :: CharParser a [NameAddr] -bcc = header "Bcc" (try address_list <|> do { optional cfws; return [] }) - --- ** Identification fields (section 3.6.4) - --- |Parse a \"@Message-Id:@\" header line and return the 'msg_id' --- contained in it. - -message_id :: CharParser a String -message_id = header "Message-ID" msg_id - --- |Parse a \"@In-Reply-To:@\" header line and return the list of --- 'msg_id's contained in it. - -in_reply_to :: CharParser a [String] -in_reply_to = header "In-Reply-To" (many1 msg_id) - --- |Parse a \"@References:@\" header line and return the list of --- 'msg_id's contained in it. - -references :: CharParser a [String] -references = header "References" (many1 msg_id) - --- |Parse a \"@message ID:@\" and return it. A message ID is almost --- identical to an 'angle_addr', but with stricter rules about folding --- and whitespace. - -msg_id :: CharParser a String -msg_id = unfold (do _ <- char '<' - idl <- id_left - _ <- char '@' - idr <- id_right - _ <- char '>' - return ("<" ++ idl ++ "@" ++ idr ++ ">")) - "message ID" - --- |Parse a \"left ID\" part of a 'msg_id'. This is almost identical to --- the 'local_part' of an e-mail address, but with stricter rules --- about folding and whitespace. - -id_left :: CharParser a String -id_left = dot_atom_text <|> no_fold_quote - "left part of an message ID" - --- |Parse a \"right ID\" part of a 'msg_id'. This is almost identical to --- the 'domain' of an e-mail address, but with stricter rules about --- folding and whitespace. - -id_right :: CharParser a String -id_right = dot_atom_text <|> no_fold_literal - "right part of an message ID" - --- |Parse one or more occurences of 'qtext' or 'quoted_pair' and --- return the concatenated string. This makes up the 'id_left' of a --- 'msg_id'. - -no_fold_quote :: CharParser a String -no_fold_quote = do _ <- dquote - r <- many (many1 qtext <|> quoted_pair) - _ <- dquote - return ("\"" ++ concat r ++ "\"") - "non-folding quoted string" - --- |Parse one or more occurences of 'dtext' or 'quoted_pair' and --- return the concatenated string. This makes up the 'id_right' of a --- 'msg_id'. - -no_fold_literal :: CharParser a String -no_fold_literal = do _ <- char '[' - r <- many (many1 dtext <|> quoted_pair) - _ <- char ']' - return ("[" ++ concat r ++ "]") - "non-folding domain literal" - - --- ** Informational fields (section 3.6.5) - --- |Parse a \"@Subject:@\" header line and return its contents verbatim. --- Please note that all whitespace and/or comments are preserved, i.e. --- the result of parsing @\"Subject: foo\"@ is @\" foo\"@, not @\"foo\"@. - -subject :: CharParser a String -subject = header "Subject" unstructured - --- |Parse a \"@Comments:@\" header line and return its contents verbatim. --- Please note that all whitespace and/or comments are preserved, i.e. --- the result of parsing @\"Comments: foo\"@ is @\" foo\"@, not @\"foo\"@. - -comments :: CharParser a String -comments = header "Comments" unstructured - --- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's --- found. Please not that each phrase is again a list of 'atom's, as --- returned by the 'phrase' parser. - -keywords :: CharParser a [[String]] -keywords = header "Keywords" (do r1 <- phrase - r2 <- many (do _ <- char ','; phrase) - return (r1:r2)) - - --- ** Resent fields (section 3.6.6) - --- |Parse a \"@Resent-Date:@\" header line and return the date it --- contains as 'CalendarTime'. - -resent_date :: CharParser a CalendarTime -resent_date = header "Resent-Date" date_time - --- |Parse a \"@Resent-From:@\" header line and return the 'mailbox_list' --- address(es) contained in it. - -resent_from :: CharParser a [NameAddr] -resent_from = header "Resent-From" mailbox_list - - --- |Parse a \"@Resent-Sender:@\" header line and return the 'mailbox_list' --- address(es) contained in it. - -resent_sender :: CharParser a NameAddr -resent_sender = header "Resent-Sender" mailbox - - --- |Parse a \"@Resent-To:@\" header line and return the 'mailbox' --- address contained in it. - -resent_to :: CharParser a [NameAddr] -resent_to = header "Resent-To" address_list - --- |Parse a \"@Resent-Cc:@\" header line and return the 'address_list' --- address(es) contained in it. - -resent_cc :: CharParser a [NameAddr] -resent_cc = header "Resent-Cc" address_list - --- |Parse a \"@Resent-Bcc:@\" header line and return the 'address_list' --- address(es) contained in it. (This list may be empty.) - -resent_bcc :: CharParser a [NameAddr] -resent_bcc = header "Resent-Bcc" ( try address_list - <|> do optional cfws - return [] - ) - "Resent-Bcc: header line" - --- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msg_id' --- contained in it. - -resent_msg_id :: CharParser a String -resent_msg_id = header "Resent-Message-ID" msg_id - - --- ** Trace fields (section 3.6.7) - -return_path :: CharParser a String -return_path = header "Return-Path" path - -path :: CharParser a String -path = unfold ( try (do _ <- char '<' - r <- option "" addr_spec - _ <- char '>' - return ("<" ++ r ++ ">") - ) - <|> obs_path - ) - "return path spec" - -received :: CharParser a ([(String,String)], CalendarTime) -received = header "Received" (do r1 <- name_val_list - _ <- char ';' - r2 <- date_time - return (r1,r2)) - -name_val_list :: CharParser a [(String,String)] -name_val_list = do optional cfws - many1 name_val_pair - "list of name/value pairs" - -name_val_pair :: CharParser a (String,String) -name_val_pair = do r1 <- item_name - _ <- cfws - r2 <- item_value - return (r1,r2) - "a name/value pair" - -item_name :: CharParser a String -item_name = do r1 <- alpha - r2 <- many $ choice [ char '-', alpha, digit ] - return (r1 : r2) - "name of a name/value pair" - -item_value :: CharParser a String -item_value = choice [ try (do { r <- many1 angle_addr; return (concat r) }) - , try addr_spec - , try domain - , msg_id - , try atom - ] - "value of a name/value pair" - --- ** Optional fields (section 3.6.8) - --- |Parse an arbitrary header field and return a tuple containing the --- 'field_name' and 'unstructured' text of the header. The name will --- /not/ contain the terminating colon. - -optional_field :: CharParser a (String,String) -optional_field = do n <- field_name - _ <- char ':' - b <- unstructured - _ <- crlf - return (n,b) - "optional (unspecified) header line" - --- |Parse and return an arbitrary header field name. That is one or --- more 'ftext' characters. - -field_name :: CharParser a String -field_name = many1 ftext "header line name" - --- |Match and return any ASCII character except for control --- characters, whitespace, and \"@:@\". - -ftext :: CharParser a Char -ftext = satisfy (\c -> ord c `elem` ([33..57] ++ [59..126])) - "character (excluding controls, space, and ':')" - - --- * Miscellaneous obsolete tokens (section 4.1) - --- |Match the obsolete \"quoted pair\" syntax, which - unlike --- 'quoted_pair' - allowed /any/ ASCII character to be specified when --- quoted. The parser will return both, the backslash and the actual --- character. - -obs_qp :: CharParser a String -obs_qp = do _ <- char '\\' - c <- satisfy (\c -> ord c `elem` [0..127]) - return ['\\',c] - "any quoted US-ASCII character" - --- |Match the obsolete \"text\" syntax, which - unlike 'text' - allowed --- \"carriage returns\" and \"linefeeds\". This is really weird; you --- better consult the RFC for details. The parser will return the --- complete string, including those special characters. - -obs_text :: CharParser a String -obs_text = do r1 <- many lf - r2 <- many cr - r3 <- many (do r4 <- obs_char - r5 <- many lf - r6 <- many cr - return (r4 : (r5 ++ r6))) - return (r1 ++ r2 ++ concat r3) - --- |Match and return the obsolete \"char\" syntax, which - unlike --- 'character' - did not allow \"carriage return\" and \"linefeed\". - -obs_char :: CharParser a Char -obs_char = satisfy (\c -> ord c `elem` ([0..9] ++ [11,12] ++ [14..127])) - "any ASCII character except CR and LF" - --- |Match and return the obsolete \"utext\" syntax, which is identical --- to 'obs_text'. - -obs_utext :: CharParser a String -obs_utext = obs_text - --- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' - --- allows dots between tokens. - -obs_phrase :: CharParser a [String] -obs_phrase = do r1 <- word - r2 <- many $ choice [ word - , string "." - , do { _ <- cfws; return [] } - ] - return (r1 : filter (/=[]) r2) - --- |Match a \"phrase list\" syntax and return the list of 'String's --- that make up the phrase. In contrast to a 'phrase', the --- 'obs_phrase_list' separates the individual words by commas. This --- syntax is - as you will have guessed - obsolete. - -obs_phrase_list :: CharParser a [String] -obs_phrase_list = do r1 <- many1 (do r <- option [] phrase - _ <- unfold $ char ',' - return (filter (/=[]) r)) - r2 <- option [] phrase - return (concat r1 ++ r2) - <|> phrase - - --- * Obsolete folding white space (section 4.2) - --- |Parse and return an \"obsolete fws\" token. That is at least one --- 'wsp' character, followed by an arbitrary number (including zero) --- of 'crlf' followed by at least one more 'wsp' character. - -obs_fws :: CharParser a String -obs_fws = do r1 <- many1 wsp - r2 <- many (do r3 <- crlf - r4 <- many1 wsp - return (r3 ++ r4)) - return (r1 ++ concat r2) - - --- * Obsolete Date and Time (section 4.3) - --- |Parse a 'day_name' but allow for the obsolete folding syntax. - -obs_day_of_week :: CharParser a Day -obs_day_of_week = unfold day_name "day-of-the-week name" - --- |Parse a 'year' but allow for a two-digit number (obsolete) and the --- obsolete folding syntax. - -obs_year :: CharParser a Int -obs_year = unfold (do r <- manyN 2 digit - return (normalize (read r :: Int))) - "year" - where - normalize n - | n <= 49 = 2000 + n - | n <= 999 = 1900 + n - | otherwise = n - --- |Parse a 'month_name' but allow for the obsolete folding syntax. - -obs_month :: CharParser a Month -obs_month = between cfws cfws month_name "month name" - --- |Parse a 'day' but allow for the obsolete folding syntax. - -obs_day :: CharParser a Int -obs_day = unfold day_of_month "day" - --- |Parse a 'hour' but allow for the obsolete folding syntax. - -obs_hour :: CharParser a Int -obs_hour = unfold hour "hour" - --- |Parse a 'minute' but allow for the obsolete folding syntax. - -obs_minute :: CharParser a Int -obs_minute = unfold minute "minute" - --- |Parse a 'second' but allow for the obsolete folding syntax. - -obs_second :: CharParser a Int -obs_second = unfold second "second" - --- |Match the obsolete zone names and return the appropriate offset. - -obs_zone :: CharParser a Int -obs_zone = choice [ mkZone "UT" 0 - , mkZone "GMT" 0 - , mkZone "EST" (-5) - , mkZone "EDT" (-4) - , mkZone "CST" (-6) - , mkZone "CDT" (-5) - , mkZone "MST" (-7) - , mkZone "MDT" (-6) - , mkZone "PST" (-8) - , mkZone "PDT" (-7) - , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 } "military zone spec" - , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 } "military zone spec" - , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } "military zone spec" - , do { _ <- char 'Z'; return 0 } "military zone spec" - ] - where mkZone n o = try $ do { _ <- string n; return (o*60*60) } - - --- * Obsolete Addressing (section 4.4) - --- |This parser matches the \"obsolete angle address\" syntax, a construct that --- used to be called \"route address\" in earlier RFCs. It differs from a --- standard 'angle_addr' in two ways: (1) it allows far more --- liberal insertion of folding whitespace and comments and (2) the address may --- contain a \"route\" (which this parser ignores): --- --- >>> parse obs_angle_addr "" "<@example1.org,@example2.org:joe@example.org>" --- Right "" - -obs_angle_addr :: CharParser a String -obs_angle_addr = unfold (do _ <- char '<' - _ <- option [] obs_route - addr <- addr_spec - _ <- char '>' - return ("<" ++ addr ++ ">") -- TODO: route is lost here. - ) - "obsolete angle address" - --- |This parser parses the \"route\" part of 'obs_angle_addr' and --- returns the list of 'String's that make up this route. Relies on --- 'obs_domain_list' for the actual parsing. - -obs_route :: CharParser a [String] -obs_route = unfold (do { r <- obs_domain_list; _ <- char ':'; return r }) - "route of an obsolete angle address" - --- |This parser parses a list of domain names, each of them prefaced --- with an \"at\". Multiple names are separated by a comma. The list of --- 'domain's is returned - and may be empty. - -obs_domain_list :: CharParser a [String] -obs_domain_list = do _ <- char '@' - r1 <- domain - r2 <- many (do _ <- cfws <|> string "," - optional cfws - _ <- char '@' - domain) - return (r1 : r2) - "route of an obsolete angle address" - --- |Parse the obsolete syntax of a 'local_part', which allowed for --- more liberal insertion of folding whitespace and comments. The --- actual string is returned. - -obs_local_part :: CharParser a String -obs_local_part = do r1 <- word - r2 <- many (do _ <- string "." - r <- word - return ('.' : r)) - return (r1 ++ concat r2) - "local part of an address" - --- |Parse the obsolete syntax of a 'domain', which allowed for more --- liberal insertion of folding whitespace and comments. The actual --- string is returned. - -obs_domain :: CharParser a String -obs_domain = do r1 <- atom - r2 <- many (do _ <- string "." - r <- atom - return ('.' : r)) - return (r1 ++ concat r2) - "domain part of an address" - --- |This parser will match the obsolete syntax for a 'mailbox_list'. --- This one is quite weird: An 'obs_mbox_list' contains an arbitrary --- number of 'mailbox'es - including none -, which are separated by --- commas. But you may have multiple consecutive commas without giving --- a 'mailbox'. You may also have a valid 'obs_mbox_list' that --- contains /no/ 'mailbox' at all. On the other hand, you /must/ have --- at least one comma. The following example is valid: --- --- >>> parse obs_mbox_list "" "," --- Right [] --- --- But this one is not: --- --- >>> parse obs_mbox_list "" "joe@example.org" --- Left (line 1, column 16): --- unexpected end of input --- expecting obsolete syntax for a list of mailboxes - -obs_mbox_list :: CharParser a [NameAddr] -obs_mbox_list = do r1 <- many1 (try (do r <- maybeOption mailbox - _ <- unfold $ char ',' - return r)) - r2 <- maybeOption mailbox - return (catMaybes (r1 ++ [r2])) - "obsolete syntax for a list of mailboxes" - --- |This parser is identical to 'obs_mbox_list' but parses a list of --- 'address'es rather than 'mailbox'es. The main difference is that an --- 'address' may contain 'group's. Please note that as of now, the --- parser will return a simple list of addresses; the grouping --- information is lost. - -obs_addr_list :: CharParser a [NameAddr] -obs_addr_list = do r1 <- many1 (try (do r <- maybeOption address - optional cfws - _ <- char ',' - optional cfws - return r)) - r2 <- maybeOption address - return (concat (catMaybes (r1 ++ [r2]))) - "obsolete syntax for a list of addresses" - - --- * Obsolete header fields (section 4.5) - -obs_fields :: GenParser Char a [Field] -obs_fields = many ( try (do { r <- obs_from; return (From r) }) - <|> try (do { r <- obs_sender; return (Sender r) }) - <|> try (do { r <- obs_return; return (ReturnPath r) }) - <|> try (do { r <- obs_reply_to; return (ReplyTo r) }) - <|> try (do { r <- obs_to; return (To r) }) - <|> try (do { r <- obs_cc; return (Cc r) }) - <|> try (do { r <- obs_bcc; return (Bcc r) }) - <|> try (do { r <- obs_message_id; return (MessageID r) }) - <|> try (do { r <- obs_in_reply_to; return (InReplyTo r) }) - <|> try (do { r <- obs_references; return (References r) }) - <|> try (do { r <- obs_subject; return (Subject r) }) - <|> try (do { r <- obs_comments; return (Comments r) }) - <|> try (do { r <- obs_keywords; return (Keywords [r]) }) - <|> try (do { r <- obs_orig_date; return (Date r) }) - <|> try (do { r <- obs_resent_date; return (ResentDate r) }) - <|> try (do { r <- obs_resent_from; return (ResentFrom r) }) - <|> try (do { r <- obs_resent_send; return (ResentSender r) }) - <|> try (do { r <- obs_resent_to; return (ResentTo r) }) - <|> try (do { r <- obs_resent_cc; return (ResentCc r) }) - <|> try (do { r <- obs_resent_bcc; return (ResentBcc r) }) - <|> try (do { r <- obs_resent_mid; return (ResentMessageID r) }) - <|> try (do { r <- obs_resent_reply; return (ResentReplyTo r) }) - <|> try (do { r <- obs_received; return (ObsReceived r) }) - -- catch all - <|> (do { (name,cont) <- obs_optional; return (OptionalField name cont) }) - ) - - --- ** Obsolete origination date field (section 4.5.1) - --- |Parse a 'date' header line but allow for the obsolete --- folding syntax. - -obs_orig_date :: CharParser a CalendarTime -obs_orig_date = obs_header "Date" date_time - - --- ** Obsolete originator fields (section 4.5.2) - --- |Parse a 'from' header line but allow for the obsolete --- folding syntax. - -obs_from :: CharParser a [NameAddr] -obs_from = obs_header "From" mailbox_list - --- |Parse a 'sender' header line but allow for the obsolete --- folding syntax. - -obs_sender :: CharParser a NameAddr -obs_sender = obs_header "Sender" mailbox - --- |Parse a 'reply_to' header line but allow for the obsolete --- folding syntax. - -obs_reply_to :: CharParser a [NameAddr] -obs_reply_to = obs_header "Reply-To" mailbox_list - - --- ** Obsolete destination address fields (section 4.5.3) - --- |Parse a 'to' header line but allow for the obsolete --- folding syntax. - -obs_to :: CharParser a [NameAddr] -obs_to = obs_header "To" address_list - --- |Parse a 'cc' header line but allow for the obsolete --- folding syntax. - -obs_cc :: CharParser a [NameAddr] -obs_cc = obs_header "Cc" address_list - --- |Parse a 'bcc' header line but allow for the obsolete --- folding syntax. - -obs_bcc :: CharParser a [NameAddr] -obs_bcc = header "Bcc" ( try address_list - <|> do { optional cfws; return [] } - ) - - --- ** Obsolete identification fields (section 4.5.4) - --- |Parse a 'message_id' header line but allow for the obsolete --- folding syntax. - -obs_message_id :: CharParser a String -obs_message_id = obs_header "Message-ID" msg_id - --- |Parse an 'in_reply_to' header line but allow for the obsolete --- folding and the obsolete phrase syntax. - -obs_in_reply_to :: CharParser a [String] -obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {_ <- phrase; return [] } - <|> msg_id - ) - return (filter (/=[]) r)) - --- |Parse a 'references' header line but allow for the obsolete --- folding and the obsolete phrase syntax. - -obs_references :: CharParser a [String] -obs_references = obs_header "References" (do r <- many ( do { _ <- phrase; return [] } - <|> msg_id - ) - return (filter (/=[]) r)) - --- |Parses the \"left part\" of a message ID, but allows the obsolete --- syntax, which is identical to a 'local_part'. - -obs_id_left :: CharParser a String -obs_id_left = local_part "left part of an message ID" - --- |Parses the \"right part\" of a message ID, but allows the obsolete --- syntax, which is identical to a 'domain'. - -obs_id_right :: CharParser a String -obs_id_right = domain "right part of an message ID" - - - --- ** Obsolete informational fields (section 4.5.5) - --- |Parse a 'subject' header line but allow for the obsolete --- folding syntax. - -obs_subject :: CharParser a String -obs_subject = obs_header "Subject" unstructured - --- |Parse a 'comments' header line but allow for the obsolete --- folding syntax. - -obs_comments :: CharParser a String -obs_comments = obs_header "Comments" unstructured - --- |Parse a 'keywords' header line but allow for the obsolete --- folding syntax. Also, this parser accepts 'obs_phrase_list'. - -obs_keywords :: CharParser a [String] -obs_keywords = obs_header "Keywords" obs_phrase_list - - --- ** Obsolete resent fields (section 4.5.6) - --- |Parse a 'resent_from' header line but allow for the obsolete --- folding syntax. - -obs_resent_from :: CharParser a [NameAddr] -obs_resent_from = obs_header "Resent-From" mailbox_list - --- |Parse a 'resent_sender' header line but allow for the obsolete --- folding syntax. - -obs_resent_send :: CharParser a NameAddr -obs_resent_send = obs_header "Resent-Sender" mailbox - --- |Parse a 'resent_date' header line but allow for the obsolete --- folding syntax. - -obs_resent_date :: CharParser a CalendarTime -obs_resent_date = obs_header "Resent-Date" date_time - --- |Parse a 'resent_to' header line but allow for the obsolete --- folding syntax. - -obs_resent_to :: CharParser a [NameAddr] -obs_resent_to = obs_header "Resent-To" mailbox_list - --- |Parse a 'resent_cc' header line but allow for the obsolete --- folding syntax. - -obs_resent_cc :: CharParser a [NameAddr] -obs_resent_cc = obs_header "Resent-Cc" mailbox_list - --- |Parse a 'resent_bcc' header line but allow for the obsolete --- folding syntax. - -obs_resent_bcc :: CharParser a [NameAddr] -obs_resent_bcc = obs_header "Bcc" ( try address_list - <|> do { optional cfws; return [] } - ) - --- |Parse a 'resent_msg_id' header line but allow for the obsolete --- folding syntax. - -obs_resent_mid :: CharParser a String -obs_resent_mid = obs_header "Resent-Message-ID" msg_id - --- |Parse a @Resent-Reply-To@ header line but allow for the --- obsolete folding syntax. - -obs_resent_reply :: CharParser a [NameAddr] -obs_resent_reply = obs_header "Resent-Reply-To" address_list - - --- ** Obsolete trace fields (section 4.5.7) - -obs_return :: CharParser a String -obs_return = obs_header "Return-Path" path - -obs_received :: CharParser a [(String, String)] -obs_received = obs_header "Received" name_val_list - --- |Match 'obs_angle_addr'. - -obs_path :: CharParser a String -obs_path = obs_angle_addr - --- |This parser is identical to 'optional_field' but allows the more --- liberal line-folding syntax between the \"field_name\" and the \"field --- text\". - -obs_optional :: CharParser a (String,String) -obs_optional = do n <- field_name - _ <- many wsp - _ <- char ':' - b <- unstructured - _ <- crlf - return (n,b) - "optional (unspecified) header line" diff --git a/doc-test.hs b/doc-test.hs deleted file mode 100644 --- a/doc-test.hs +++ /dev/null @@ -1,22 +0,0 @@ -{- - Module : Main - Copyright : (c) 2013 Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - HsEmail doctest suite. --} - -module Main ( main ) where - -import Test.DocTest - -main :: IO () -main = doctest - [ "Text/ParserCombinators/Parsec/Rfc2234.hs" - , "Text/ParserCombinators/Parsec/Rfc2821.hs" - , "Text/ParserCombinators/Parsec/Rfc2822.hs" - ] diff --git a/example/message-test.hs b/example/message-test.hs deleted file mode 100644 --- a/example/message-test.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Main (main) where - -import Text.ParserCombinators.Parsec ( parse ) -import Text.ParserCombinators.Parsec.Rfc2822 - --- Read an Internet message from standard input, parse it, --- and return the result. - -main :: IO () -main = do - input <- getContents - print $ parse message "" (fixEol input) - return () - --- Make sure all lines are terminated by CRLF. - -fixEol :: String -> String -fixEol ('\r':'\n':xs) = '\r' : '\n' : fixEol xs -fixEol ('\n':xs) = '\r' : '\n' : fixEol xs -fixEol (x:xs) = x : fixEol xs -fixEol [] = [] diff --git a/example/message-test.input b/example/message-test.input deleted file mode 100644 --- a/example/message-test.input +++ /dev/null @@ -1,20 +0,0 @@ -X-From-Line: rtMj@example.org Tue Jun 22 15:11:15 2004 -Return-Path: -Received: from example.org ([127.0.0.1]) - by peti.cryp.to with SMTP id i5MDBAW8014197 for ; - Tue, 22 Jun 2004 15:11:12 +0200 -Received: (qmail 076 invoked from network); Tue, 22 Jun 2004 09:09:16 -0400 -Message-ID: -From: "virtual shop" -To: simons@cryp.to -Subject: PROTECT your Computer from tampering ! 315683 -Date: Tue, 22 Jun 2004 09:09:16 -0400 -Mime-Version: 1.0 -Content-Type: multipart/alternative; - boundary="----=_NextPart_013_7A25_1AC67A25.1AC67A25" -X-Priority: 3 -X-MSMail-Priority: Normal -X-Mailer: Microsoft Outlook Express 6.00.2800.1409 -X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2800.1409 - -This is a spam message. diff --git a/example/smtp-test.hs b/example/smtp-test.hs deleted file mode 100644 --- a/example/smtp-test.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main (main) where - -import Text.ParserCombinators.Parsec ( parse ) -import Text.ParserCombinators.Parsec.Rfc2821 - --- Read an SMTP command from standard input, parse it, --- return the result, and loop until EOF. - -main :: IO () -main = do - input <- getContents - mapM_ (print . parse smtpCmd "") [ l ++ "\r\n" | l <- lines input ] diff --git a/example/smtp-test.input b/example/smtp-test.input deleted file mode 100644 --- a/example/smtp-test.input +++ /dev/null @@ -1,7 +0,0 @@ -helo smtp.example.org -mail from: -rcpt to: -RCPT to:<@example.org,@example.com:joe.doe@example.net> -VrFy localuser -data -quit diff --git a/hsemail.cabal b/hsemail.cabal --- a/hsemail.cabal +++ b/hsemail.cabal @@ -1,40 +1,72 @@ -Name: hsemail -Version: 1.7.7 -Copyright: (c) 2013 Peter Simons -License: BSD3 -License-File: LICENSE -Author: Peter Simons , Gero Kriependorf , Marty Pauley -Maintainer: Peter Simons -Homepage: http://github.com/peti/hsemail -Category: Parsing -Synopsis: Internet Message Parsers -Description: Parsers for the syntax defined in RFC2821 and 2822 -Cabal-Version: >= 1.8 -Build-Type: Simple -Tested-With: GHC >= 6.12.3 && <= 7.6.3 +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack -Extra-Source-Files: example/message-test.hs - example/message-test.input - example/smtp-test.hs - example/smtp-test.input +name: hsemail +version: 2 +synopsis: Parsec parsers for the RFC2822 Internet Message format +description: Parsec parsers for the Internet Message format defined in RFC 2821 and 2822. +category: Parsing +stability: stable +homepage: https://github.com/peti/hsemail#readme +bug-reports: https://github.com/peti/hsemail/issues +author: Peter Simons, + Ali Abrar, + Gero Kriependorf, + Marty Pauley +maintainer: Peter Simons +license: BSD3 +license-file: LICENSE +tested-with: GHC > 7.8 && < 8.1 +build-type: Simple +cabal-version: >= 1.10 -Source-Repository head - Type: git - Location: git://github.com/peti/hsemail.git +source-repository head + type: git + location: https://github.com/peti/hsemail -Library - Build-Depends: base >= 3 && < 5, mtl, parsec, old-time - Exposed-Modules: Text.ParserCombinators.Parsec.Rfc2234 - Text.ParserCombinators.Parsec.Rfc2821 - Text.ParserCombinators.Parsec.Rfc2822 - Ghc-Options: -Wall +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , old-time + , parsec >= 3.1 + , mtl + exposed-modules: + Text.Parsec.Rfc2234 + Text.Parsec.Rfc2821 + Text.Parsec.Rfc2822 + other-modules: + Paths_hsemail + default-language: Haskell2010 -Test-Suite test-hsemail - type: exitcode-stdio-1.0 - main-is: self-test.hs - build-depends: base, hspec, parsec, old-time +test-suite doctest-hsemail + type: exitcode-stdio-1.0 + main-is: doctest.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , old-time + , parsec >= 3.1 + , mtl + , doctest + default-language: Haskell2010 -Test-Suite doctest-hsemail - type: exitcode-stdio-1.0 - main-is: doc-test.hs - build-depends: base, doctest +test-suite test-hsemail + type: exitcode-stdio-1.0 + main-is: spec.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , old-time + , parsec >= 3.1 + , mtl + , hspec + , hsemail + default-language: Haskell2010 diff --git a/self-test.hs b/self-test.hs deleted file mode 100644 --- a/self-test.hs +++ /dev/null @@ -1,308 +0,0 @@ -{- - Module : Main - Copyright : (c) 2013 Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - HsEmail regression test suite. --} - -module Main ( main ) where - -import Test.Hspec -import System.Time ( CalendarTime(..), Month(..), Day(..) ) -import Text.ParserCombinators.Parsec ( parse, eof, CharParser ) -import Text.ParserCombinators.Parsec.Rfc2822 - -parseTest :: CharParser () a -> String -> IO a -parseTest p input = case parse (do { r <- p; eof; return r }) (show input) input of - Left err -> fail ("parse error at " ++ show err) - Right r -> return r - -parseIdemTest :: CharParser () String -> String -> Expectation -parseIdemTest p input = parseTest p input `shouldReturn` input - -parseFailure :: (Show a) => CharParser () a -> String -> Expectation -parseFailure p input = parse (do { r <- p; eof; return r }) (show input) input `shouldSatisfy` failure - where - failure (Left _) = True - failure _ = False - -main :: IO () -main = hspec $ do - describe "Rfc2822.quoted_pair" $ - it "can quote a nul byte" $ - parseIdemTest quoted_pair "\\\0" - - describe "Rfc2822.date_time" $ - it "parses hand-picked times correctly" $ - parseTest date_time "Fri, 21 Dec 2012 00:07:43 +0300" `shouldReturn` - CalendarTime 2012 December 21 0 7 43 0 Friday 0 "" 10800 False - - describe "Rfc2822.day" $ do - it "parses a hand-picked day-of-months correctly" $ do - parseTest day "00" `shouldReturn` 0 - parseTest day "09" `shouldReturn` 9 - parseTest day "15" `shouldReturn` 15 - - it "does not perform range checking" $ - parseTest day "99" `shouldReturn` 99 - - it "fails properly on incomplete input" $ do - parseFailure day "Mon" - parseFailure day "Thu" - - describe "Rfc2822.obs_mbox_list" $ do - it "parses hand-picked inputs correctly" $ do - parseTest obs_mbox_list "," `shouldReturn` [] - parseTest obs_mbox_list "Joe Doe ,( \r\n bla),,jane@\r\n example.net \r\n (Jane Doe)," `shouldReturn` - [NameAddr (Just "Joe Doe") "joe@example.org",NameAddr Nothing "jane@example.net"] - - it "fails properly on incomplete input" $ - parseFailure obs_mbox_list "foo@example.org" - - describe "Rfc2822.subject" $ - it "doesn't consume leading whitespace" $ - parseTest subject "Subject: foo\r\n" `shouldReturn` " foo" - - describe "Rfc2822.comment" $ - it "doesn't consume leading whitespace" $ - parseTest comments "Comments: foo\r\n" `shouldReturn` " foo" - - -- Most of the following test cases have been adapted from - -- . - describe "Rfc2822.addr_spec" $ - it "parses hand-picked inputs correctly" $ do - parseFailure addr_spec "()[]\\;:,><@example.com" -- Disallowed Characters - parseFailure addr_spec " -- test --@example.com" -- No spaces allowed in local part - parseFailure addr_spec "-@..com" - parseFailure addr_spec "-@a..com" - parseFailure addr_spec ".@" - parseFailure addr_spec ".@example.com" -- Phil Haack says so - parseFailure addr_spec ".dot@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec ".first.last@example.com" -- Local part starts with a dot - parseFailure addr_spec ".test@example.com" - parseFailure addr_spec ".wooly@example.com" -- Phil Haack says so - parseFailure addr_spec "@@bar.com" - parseFailure addr_spec "@NotAnEmail" -- Phil Haack says so - parseFailure addr_spec "@bar.com" - parseFailure addr_spec "@example.com" -- No local part - parseFailure addr_spec "Abc\\@def@example.com" -- Was incorrectly given as a valid address in the original RFC3696 - parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ L\\.@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ Lovell@example.com" -- Escaping can only happen in a quoted string - parseFailure addr_spec "Fred\\ Bloggs@example.com" -- Was incorrectly given as a valid address in the original RFC3696 - parseFailure addr_spec "Ima Fool@example.com" -- Phil Haack says so - parseFailure addr_spec "Invalid \\\n Folding \\\n Whitespace@example.com" -- This isn't FWS so Dominic Sayers says it's invalid - parseFailure addr_spec "Joe.\\\\Blow@example.com" -- Was incorrectly given as a valid address in the original RFC3696 - parseFailure addr_spec "NotAnEmail" -- Phil Haack says so - parseFailure addr_spec "[test]@example.com" -- Square brackets only allowed within quotes - parseFailure addr_spec "\"Doug \"Ace\" L.\"@example.com" -- Doug Lovell says this should fail - parseIdemTest addr_spec "\"\"@example.com" - parseFailure addr_spec "\"\"\"@example.com" -- Local part contains unescaped excluded characters - parseFailure addr_spec "\"\\\"@example.com" -- Local part cannot end with a backslash - parseFailure addr_spec "\"first\"last\"@example.com" -- Local part contains unescaped excluded characters - parseFailure addr_spec "\"first\\\\\"last\"@example.com" -- Contains an unescaped quote - parseFailure addr_spec "\"foo\"(yay)@(hoopla)[1.2.3.4]" -- Address literal can't be commented (RFC5321) - parseFailure addr_spec "\"null \NUL\"@char.com" -- cannot have unescaped null character - parseFailure addr_spec "\"qu@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "\"test\"blah\"@example.com" -- Phil Haack says so - parseFailure addr_spec "\"test\"test\"@example.com" -- Quotes cannot be nested - parseFailure addr_spec "\"test\\\r\n blah\"@example.com" -- Folding white space can't appear within a quoted pair - parseFailure addr_spec "\"test\rblah\"@example.com" -- Quoted string specifically excludes carriage returns - parseFailure addr_spec "a(a(b(c)d(e(f))g)(h(i)j)@example.com" -- Braces are not properly matched - parseFailure addr_spec "a@bar.com." - parseFailure addr_spec "aaa.com" - parseFailure addr_spec "aaa@.123" - parseFailure addr_spec "aaa@.com" - parseFailure addr_spec "aaa@[123.123.123.123]a" -- extra data outside ip - parseFailure addr_spec "abc@def@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "abc\\@def@example.com" -- This example from RFC3696 was corrected in an erratum - parseFailure addr_spec "abc\\@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "abc\\\\@def@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "abc\\\\@example.com" -- This example from RFC3696 was corrected in an erratum - parseFailure addr_spec "cal(foo(bar)@iamcal.com" -- Unclosed parenthesis in comment - parseFailure addr_spec "cal(foo)bar)@iamcal.com" -- Too many closing parentheses - parseFailure addr_spec "cal(foo\\)@iamcal.com" -- Backslash at end of comment has nothing to escape - parseFailure addr_spec "dot.@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "doug@" -- Doug Lovell says this should fail - parseFailure addr_spec "first(12345678901234567890123456789012345678901234567890)last@(1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890)example.com" -- Too long with comments, not too long without - parseFailure addr_spec "first(abc(\"def\".ghi).mno)middle(abc(\"def\".ghi).mno).last@(abc(\"def\".ghi).mno)example(abc(\"def\".ghi).mno).(abc(\"def\".ghi).mno)com(abc(\"def\".ghi).mno)" -- Can't have comments or white space except at an element boundary - parseFailure addr_spec "first(middle)last@example.com" -- Can't have a comment or white space except at an element boundary - parseFailure addr_spec "first..last@example.com" -- Local part has consecutive dots - parseFailure addr_spec "first.last" -- No @ - parseFailure addr_spec "first.last.@example.com" -- Local part ends with a dot - parseFailure addr_spec "first.last@" -- No domain - parseFailure addr_spec "first\\@last@example.com" -- Escaping can only happen within a quoted string - parseFailure addr_spec "first\\\\@last@example.com" -- Local part contains unescaped excluded characters - parseFailure addr_spec "first\\last@example.com" -- Unquoted string must be an atom - parseFailure addr_spec "gatsby@f.sc.ot.t.f.i.tzg.era.l.d." -- Doug Lovell says this should fail - parseFailure addr_spec "hello world@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "ote\"@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "phil.h\\@\\@ck@haacked.com" -- Escaping can only happen in a quoted string - parseFailure addr_spec "pootietang.@example.com" -- Phil Haack says so - parseFailure addr_spec "test..test@example.com" - parseFailure addr_spec "test.@example.com" - parseFailure addr_spec "test.\r\n\r\n obs@syntax.com" -- obs-fws must have at least one WSP per line - parseFailure addr_spec "test.example.com" - parseFailure addr_spec "test@." -- Dave Child says so - parseFailure addr_spec "test@...........com" -- ...... - parseFailure addr_spec "test@.org" -- Dave Child says so - parseFailure addr_spec "test@123.123.123.123]" -- Dave Child says so - parseFailure addr_spec "test@@example.com" - parseFailure addr_spec "test@[123.123.123.123" -- Dave Child says so - parseFailure addr_spec "test@example." -- Dave Child says so - parseFailure addr_spec "test@test@example.com" - parseFailure addr_spec "two..dot@example.com" -- Doug Lovell says this should fail - parseFailure addr_spec "wo..oly@example.com" -- Phil Haack says so - parseFailure addr_spec "{^c\\@**Dog^}@cartoon.com" -- This is a throwaway example from Doug Lovell's article. Actually it's not a valid address. - parseTest addr_spec " \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n ( x \r\n ) \r\n @example.com" `shouldReturn` "first.last@example.com" - parseIdemTest addr_spec "!def!xyz%abc@example.com" - parseIdemTest addr_spec "$A12345@example.com" - parseTest addr_spec "(foo)cal(bar)@(baz)iamcal.com(quux)" `shouldReturn` "cal@iamcal.com" - parseIdemTest addr_spec "+1~1+@example.com" - parseIdemTest addr_spec "+@b.c" -- TLDs can be any length - parseIdemTest addr_spec "+@b.com" - parseTest addr_spec "1234 @ local(blah) .machine .example" `shouldReturn` "1234@local.machine.example" - parseIdemTest addr_spec "1234567890123456789012345678901234567890123456789012345678901234@example.com" - parseIdemTest addr_spec "123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.123456789012345678901234567890123456789012345678901234567890123.example.com" - parseIdemTest addr_spec "1234567890@example.com" - parseTest addr_spec "HM2Kinsists@(that comments are allowed)this.is.ok" `shouldReturn` "HM2Kinsists@this.is.ok" - parseIdemTest addr_spec "Ima.Fool@example.com" - parseIdemTest addr_spec "TEST@example.com" - parseTest addr_spec "Test.\r\n Folding.\r\n Whitespace@example.com" `shouldReturn` "Test.Folding.Whitespace@example.com" - parseIdemTest addr_spec "\"Abc@def\"@example.com" - parseIdemTest addr_spec "\"Abc\\@def\"@example.com" - parseIdemTest addr_spec "\"Austin@Powers\"@example.com" - parseIdemTest addr_spec "\"Doug \\\"Ace\\\" L.\"@example.com" - parseIdemTest addr_spec "\"Fred Bloggs\"@example.com" - parseIdemTest addr_spec "\"Fred\\ Bloggs\"@example.com" - parseIdemTest addr_spec "\"Ima Fool\"@example.com" - parseIdemTest addr_spec "\"Ima.Fool\"@example.com" - parseIdemTest addr_spec "\"Joe.\\\\Blow\"@example.com" - parseIdemTest addr_spec "\"Joe\\\\Blow\"@example.com" - parseIdemTest addr_spec "\"Test \\\"Fail\\\" Ing\"@example.com" - parseIdemTest addr_spec "\"[[ test ]]\"@example.com" - parseIdemTest addr_spec "\"first last\"@example.com" - parseIdemTest addr_spec "\"first(last)\"@example.com" - parseIdemTest addr_spec "\"first..last\"@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "\"first.middle.last\"@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "\"first.middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "\"first@last\"@example.com" - parseIdemTest addr_spec "\"first\".\"last\"@example.com" - parseIdemTest addr_spec "\"first\".\"middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "\"first\".last@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "\"first\".middle.\"last\"@example.com" - parseIdemTest addr_spec "\"first\\\"last\"@example.com" - parseIdemTest addr_spec "\"first\\\\\\\"last\"@example.com" - parseIdemTest addr_spec "\"first\\\\last\"@example.com" - parseIdemTest addr_spec "\"first\\last\"@example.com" -- Any character can be escaped in a quoted string - parseIdemTest addr_spec "\"hello my name is\"@stutter.com" - parseIdemTest addr_spec "\"null \\\NUL\"@char.com" -- can have escaped null character - parseIdemTest addr_spec "\"test.test\"@example.com" - parseIdemTest addr_spec "\"test@test\"@example.com" - parseIdemTest addr_spec "\"test\\\"blah\"@example.com" - parseIdemTest addr_spec "\"test\\\\blah\"@example.com" - parseIdemTest addr_spec "\"test\\\rblah\"@example.com" -- Quoted string specifically excludes carriage returns unless escaped - parseIdemTest addr_spec "\"test\\blah\"@example.com" -- Any character can be escaped in a quoted string - parseIdemTest addr_spec "\"test\\test\"@example.com" -- Any character can be escaped in a quoted string - parseIdemTest addr_spec "\"test\r\n blah\"@example.com" -- This is a valid quoted string with folding white space - parseIdemTest addr_spec "_Yosemite.Sam@example.com" - parseIdemTest addr_spec "_somename@example.com" - parseTest addr_spec "a(a(b(c)d(e(f))g)h(i)j)@example.com" `shouldReturn` "a@example.com" - parseIdemTest addr_spec "a-b@bar.com" - parseIdemTest addr_spec "a@b.co-foo.uk" - parseIdemTest addr_spec "a@bar.com" - parseIdemTest addr_spec "aaa@[123.123.123.123]" - parseTest addr_spec "c@(Chris's host.)public.example" `shouldReturn` "c@public.example" - parseTest addr_spec "cal(foo\\)bar)@iamcal.com" `shouldReturn` "cal@iamcal.com" - parseTest addr_spec "cal(foo\\@bar)@iamcal.com" `shouldReturn` "cal@iamcal.com" - parseTest addr_spec "cal(woo(yay)hoopla)@iamcal.com" `shouldReturn` "cal@iamcal.com" - parseTest addr_spec "cal@iamcal(woo).(yay)com" `shouldReturn` "cal@iamcal.com" - parseIdemTest addr_spec "customer/department=shipping@example.com" - parseIdemTest addr_spec "customer/department@example.com" - parseIdemTest addr_spec "dclo@us.ibm.com" - parseTest addr_spec "first().last@example.com" `shouldReturn` "first.last@example.com" - parseTest addr_spec "first(Welcome to\r\n the (\"wonderful\" (!)) world\r\n of email)@example.com" `shouldReturn` "first@example.com" - parseTest addr_spec "first(a\"bc.def).last@example.com" `shouldReturn` "first.last@example.com" - parseTest addr_spec "first(abc.def).last@example.com" `shouldReturn` "first.last@example.com" - parseTest addr_spec "first(abc\\(def)@example.com" `shouldReturn` "first@example.com" - parseTest addr_spec "first.(\")middle.last(\")@example.com" `shouldReturn` "first.middle.last@example.com" - parseTest addr_spec "first.(\r\n middle\r\n )last@example.com" `shouldReturn` "first.last@example.com" - parseIdemTest addr_spec "first.\"last\"@example.com" -- obs-local-part form as described in RFC 2822 - parseIdemTest addr_spec "first.\"mid\\dle\".\"last\"@example.com" -- Backslash can escape anything but must escape something - parseIdemTest addr_spec "first.last@123.example.com" - parseIdemTest addr_spec "first.last@1xample.com" - parseIdemTest addr_spec "first.last@[12.34.56.78]" - parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.56.78]" - parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]" - parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666::]" - parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:12.34.56.78]" - parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:5555:6666]" - parseIdemTest addr_spec "first.last@[IPv6:::1111:2222:3333:4444:5555:6666]" - parseIdemTest addr_spec "first.last@[IPv6:::12.34.56.78]" - parseIdemTest addr_spec "first.last@example.com" - parseTest addr_spec "first.last@x(1234567890123456789012345678901234567890123456789012345678901234567890).com" `shouldReturn` "first.last@x.com" - parseIdemTest addr_spec "first.last@x23456789012345678901234567890123456789012345678901234567890123.example.com" - parseTest addr_spec "jdoe@machine(comment). example" `shouldReturn` "jdoe@machine.example" - parseIdemTest addr_spec "name.lastname@domain.com" - parseTest addr_spec "pete(his account)@silly.test(his host)" `shouldReturn` "pete@silly.test" - parseIdemTest addr_spec "peter.piper@example.com" - parseIdemTest addr_spec "shaitan@my-domain.thisisminekthx" -- Disagree with Paul Gregg here - parseIdemTest addr_spec "t*est@example.com" - parseIdemTest addr_spec "test+test@example.com" - parseIdemTest addr_spec "test-test@example.com" - parseTest addr_spec "test. \r\n \r\n obs@syntax.com" `shouldReturn` "test.obs@syntax.com" - parseTest addr_spec "test.\"test\"@example.com" `shouldReturn` "test.\"test\"@example.com" - parseTest addr_spec "test.\r\n \r\n obs@syntax.com" `shouldReturn` "test.obs@syntax.com" - parseIdemTest addr_spec "test.test@example.com" - parseIdemTest addr_spec "test@123.123.123.x123" - parseIdemTest addr_spec "test@[123.123.123.123]" - parseIdemTest addr_spec "test@example.com" - parseIdemTest addr_spec "test@example.example.com" - parseIdemTest addr_spec "test@example.example.example.com" - parseIdemTest addr_spec "user%uucp!path@somehost.edu" - parseIdemTest addr_spec "user+mailbox@example.com" - parseIdemTest addr_spec "valid@special.museum" - parseIdemTest addr_spec "x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x234" - parseIdemTest addr_spec "{_test_}@example.com" - parseIdemTest addr_spec "~@example.com" - - describe "Rfc2822.path" $ do - it "parses hand-picked inputs correctly" $ - parseTest path " " `shouldReturn` "" - it "loses the route-part of an obsolete routing address" $ - parseTest path "<@example1.org,@example2.org:joe@example.org>" `shouldReturn` "" - - describe "Rfc2822.dot_atom" $ do - it "consumes leading and trailing whitespace" $ - parseTest dot_atom " first.last " `shouldReturn` "first.last" - it "does not allow interspersed whitespace" $ do - parseFailure dot_atom "first . last" - parseFailure dot_atom "first .last" - parseFailure dot_atom "first. last" - - describe "Rfc2822.local_part" $ do - it "consumes leading and trailing whitespace" $ - parseTest local_part " first.last " `shouldReturn` "first.last" - it "consumes interspersed whitespace (obsolete syntax)" $ do - parseTest local_part " first . last " `shouldReturn` "first.last" - parseTest local_part " first .last " `shouldReturn` "first.last" - parseTest local_part " first. last " `shouldReturn` "first.last" - - describe "Rfc2822.return_path" $ do - it "parses hand-picked inputs correctly" $ do - parseTest return_path "Return-Path: \r\n" `shouldReturn` "" - parseTest return_path "Return-Path: <>\r\n" `shouldReturn` "<>" - it "loses the route-part of an obsolete routing address" $ - parseTest return_path "Return-Path: <@example1.org,@example2.org:joe@example.org>\r\n" `shouldReturn` "" - - describe "Rfc2822.word" $ - it "parses hand-picked inputs correctly" $ - parseTest word " foobar " `shouldReturn` "foobar" - - describe "Rfc2822.body" $ - it "parses 8-bit characters correctly" $ - parseIdemTest body "abc äöüß def" diff --git a/src/Text/Parsec/Rfc2234.hs b/src/Text/Parsec/Rfc2234.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Rfc2234.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE FlexibleContexts #-} +{- | + Module : Text.Parsec.Rfc2234 + Copyright : (c) 2013 Peter Simons + License : BSD3 + + Maintainer : simons@cryp.to + Stability : provisional + Portability : portable + + This module provides parsers for the grammar defined in + RFC2234, \"Augmented BNF for Syntax Specifications: + ABNF\", . The + terminal called @char@ in the RFC is called 'character' + here to avoid conflicts with Parsec's 'char' function. + -} + +module Text.Parsec.Rfc2234 where + +import Control.Monad ( liftM2, replicateM ) +import Data.Char ( toUpper, chr, ord ) +import Text.Parsec hiding (crlf) +import qualified Text.Parsec.String as PS + +-- Customize hlint ... +{-# ANN module "HLint: ignore Use camelCase" #-} + +---------------------------------------------------------------------- +-- * Parser Combinators +---------------------------------------------------------------------- + +-- |Case-insensitive variant of Parsec's 'char' function. + +caseChar :: Stream s m Char => Char -> ParsecT s u m Char +caseChar c = satisfy (\x -> toUpper x == toUpper c) + +-- |Case-insensitive variant of Parsec's 'string' function. + +caseString :: Stream s m Char => String -> ParsecT s u m () +caseString cs = mapM_ caseChar cs cs + +-- |Match a parser at least @n@ times. + +-- manyN :: Int -> GenParser a b c -> GenParser a b [c] +manyN :: Int -> ParsecT s u m a -> ParsecT s u m [a] +manyN n p + | n <= 0 = return [] + | otherwise = liftM2 (++) (replicateM n p) (many p) + +-- |Match a parser at least @n@ times, but no more than @m@ times. + +manyNtoM :: Int -> Int -> ParsecT s u m a -> ParsecT s u m [a] +manyNtoM n m p + | n < 0 = return [] + | n > m = return [] + | n == m = replicateM n p + | n == 0 = foldr (<|>) (return []) (map (\x -> try $ replicateM x p) (reverse [1..m])) + | otherwise = liftM2 (++) (replicateM n p) (manyNtoM 0 (m-n) p) + +-- |Helper function to generate 'Parser'-based instances for +-- the 'Read' class. + +parsec2read :: PS.Parser a -> String -> [(a, String)] +parsec2read f x = either (error . show) id (parse f' "" x) + where + f' = do { a <- f; res <- getInput; return [(a,res)] } + + +---------------------------------------------------------------------- +-- * Primitive Parsers +---------------------------------------------------------------------- + +-- |Match any character of the alphabet. + +alpha :: Stream s m Char => ParsecT s u m Char +alpha = satisfy (\c -> c `elem` (['A'..'Z'] ++ ['a'..'z'])) + "alphabetic character" + +-- |Match either \"1\" or \"0\". + +bit :: Stream s m Char => ParsecT s u m Char +bit = oneOf "01" "bit ('0' or '1')" + +-- |Match any 7-bit US-ASCII character except for NUL (ASCII value 0, that is). + +character :: Stream s m Char => ParsecT s u m Char +character = satisfy (\c -> (c >= chr 1) && (c <= chr 127)) + "7-bit character excluding NUL" + +-- |Match the carriage return character @\\r@. + +cr :: Stream s m Char => ParsecT s u m Char +cr = char '\r' "carriage return" + +-- |Match returns the linefeed character @\\n@. + +lf :: Stream s m Char => ParsecT s u m Char +lf = char '\n' "linefeed" + +-- |Match the Internet newline @\\r\\n@. + +crlf :: Stream s m Char => ParsecT s u m String +crlf = do c <- cr + l <- lf + return [c,l] + "carriage return followed by linefeed" + +-- |Match any US-ASCII control character. That is +-- any character with a decimal value in the range of [0..31,127]. + +ctl :: Stream s m Char => ParsecT s u m Char +ctl = satisfy (\c -> ord c `elem` ([0..31] ++ [127])) + "control character" + +-- |Match the double quote character \"@\"@\". + +dquote :: Stream s m Char => ParsecT s u m Char +dquote = char (chr 34) "double quote" + +-- |Match any character that is valid in a hexadecimal number; +-- [\'0\'..\'9\'] and [\'A\'..\'F\',\'a\'..\'f\'] that is. + +hexdig :: Stream s m Char => ParsecT s u m Char +hexdig = hexDigit "hexadecimal digit" + +-- |Match the tab (\"@\\t@\") character. + +htab :: Stream s m Char => ParsecT s u m Char +htab = char '\t' "horizontal tab" + +-- |Match \"linear white-space\". That is any number of consecutive +-- 'wsp', optionally followed by a 'crlf' and (at least) one more +-- 'wsp'. + +lwsp :: Stream s m Char => ParsecT s u m String +lwsp = do r <- choice + [ many1 wsp + , try (liftM2 (++) crlf (many1 wsp)) + ] + rs <- option [] lwsp + return (r ++ rs) + "linear white-space" + +-- |Match /any/ character. +octet :: Stream s m Char => ParsecT s u m Char +octet = anyChar "any 8-bit character" + +-- |Match the space. + +sp :: Stream s m Char => ParsecT s u m Char +sp = char ' ' "space" + +-- |Match any printable ASCII character. (The \"v\" stands for +-- \"visible\".) That is any character in the decimal range of +-- [33..126]. + +vchar :: Stream s m Char => ParsecT s u m Char +vchar = satisfy (\c -> (c >= chr 33) && (c <= chr 126)) + "printable character" + +-- |Match either 'sp' or 'htab'. + +wsp :: Stream s m Char => ParsecT s u m Char +wsp = sp <|> htab "white-space" + + +-- ** Useful additions + +-- |Match a \"quoted pair\". Any characters (excluding CR and +-- LF) may be quoted. + +quoted_pair :: Stream s m Char => ParsecT s u m String +quoted_pair = do _ <- char '\\' + r <- noneOf "\r\n" + return ['\\',r] + "quoted pair" + +-- |Match a quoted string. The specials \"@\\@\" and +-- \"@\"@\" must be escaped inside a quoted string; CR and +-- LF are not allowed at all. + +quoted_string :: Stream s m Char => ParsecT s u m String +quoted_string = do _ <- dquote + r <- many qcont + _ <- dquote + return ("\"" ++ concat r ++ "\"") + "quoted string" + where + qtext = noneOf "\\\"\r\n" + qcont = many1 qtext <|> quoted_pair diff --git a/src/Text/Parsec/Rfc2821.hs b/src/Text/Parsec/Rfc2821.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Rfc2821.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE FlexibleContexts #-} +{- | + Module : Text.Parsec.Rfc2821 + Copyright : (c) 2013 Peter Simons + License : BSD3 + + Maintainer : simons@cryp.to + Stability : provisional + Portability : portable + + This module exports parser combinators for the grammar + described in RFC2821, \"Simple Mail Transfer Protocol\", + . +-} + +module Text.Parsec.Rfc2821 where + +import Text.Parsec.Rfc2234 + +import Control.Exception ( assert ) +import Control.Monad.State +import Data.Char ( toLower ) +import Data.List ( intercalate ) +import Text.Parsec hiding (crlf) + +-- Customize hlint ... +{-# ANN module "HLint: ignore Use camelCase" #-} + +---------------------------------------------------------------------- +-- * ESMTP State Machine +---------------------------------------------------------------------- + +data SessionState + = Unknown + | HaveHelo + | HaveMailFrom + | HaveRcptTo + | HaveData + | HaveQuit + deriving (Enum, Bounded, Eq, Ord, Show) + +data Event + = Greeting -- ^ reserved for the user + | SayHelo String + | SayHeloAgain String + | SayEhlo String + | SayEhloAgain String + | SetMailFrom Mailbox + | AddRcptTo Mailbox + | StartData + | Deliver -- ^ reserved for the user + | NeedHeloFirst + | NeedMailFromFirst + | NeedRcptToFirst + | NotImplemened + -- ^ 'Turn', 'Send', 'Soml', 'Saml', 'Vrfy', and 'Expn'. + | ResetState + | SayOK + -- ^ Triggered in case of 'Noop' or when 'Rset' is + -- used before we even have a state. + | SeeksHelp String + -- ^ The parameter may be @[]@. + | Shutdown + | SyntaxErrorIn String + | Unrecognized String + deriving (Eq, Show) + +type SmtpdFSM = Control.Monad.State.State SessionState Event + +-- |Parse a line of SMTP dialogue and run 'handleSmtpCmd' to +-- determine the 'Event'. In case of syntax errors, +-- 'SyntaxErrorIn' or 'Unrecognized' will be returned. +-- Inputs must be terminated with 'crlf'. See 'fixCRLF'. + +smtpdFSM :: String -> SmtpdFSM +smtpdFSM str = either + (\_ -> return (Unrecognized str)) + handleSmtpCmd + (parse smtpCmd "" str) + +-- |For those who want to parse the 'SmtpCmd' themselves. +-- Calling this function in 'HaveQuit' or 'HaveData' will +-- fail an assertion. If 'assert' is disabled, it will +-- return respectively 'Shutdown' and 'StartData' again. + +handleSmtpCmd :: SmtpCmd -> SmtpdFSM +handleSmtpCmd cmd = get >>= \st -> match st cmd + where + match :: SessionState -> SmtpCmd -> SmtpdFSM + match HaveQuit _ = assert False (event Shutdown) + match HaveData _ = assert False (trans (HaveData, StartData)) + match _ (WrongArg c _) = event (SyntaxErrorIn c) + match _ Quit = trans (HaveQuit, Shutdown) + match _ Noop = event SayOK + match _ Turn = event NotImplemened + + match _ (Send _) = event NotImplemened + match _ (Soml _) = event NotImplemened + match _ (Saml _) = event NotImplemened + match _ (Vrfy _) = event NotImplemened + match _ (Expn _) = event NotImplemened + match _ (Help x) = event (SeeksHelp x) + + match Unknown Rset = event SayOK + match HaveHelo Rset = event SayOK + match _ Rset = trans (HaveHelo, ResetState) + + match Unknown (Helo x) = trans (HaveHelo, SayHelo x) + match _ (Helo x) = trans (HaveHelo, SayHeloAgain x) + match Unknown (Ehlo x) = trans (HaveHelo, SayEhlo x) + match _ (Ehlo x) = trans (HaveHelo, SayEhloAgain x) + + match Unknown (MailFrom _) = event NeedHeloFirst + match _ (MailFrom x) = trans (HaveMailFrom, SetMailFrom x) + + match Unknown (RcptTo _) = event NeedHeloFirst + match HaveHelo (RcptTo _) = event NeedMailFromFirst + match _ (RcptTo x) = trans (HaveRcptTo, AddRcptTo x) + + match Unknown Data = event NeedHeloFirst + match HaveHelo Data = event NeedMailFromFirst + match HaveMailFrom Data = event NeedRcptToFirst + match HaveRcptTo Data = trans (HaveData, StartData) + + event :: Event -> SmtpdFSM + event = return + + trans :: (SessionState, Event) -> SmtpdFSM + trans (st,e) = put st >> event e + + +---------------------------------------------------------------------- +-- * Data Types for SMTP Commands +---------------------------------------------------------------------- + +-- |The 'smtpCmd' parser will create this data type from a +-- string. Note that /all/ command parsers expect their +-- input to be terminated with 'crlf'. + +data SmtpCmd + = Helo String + | Ehlo String + | MailFrom Mailbox -- ^ Might be 'nullPath'. + | RcptTo Mailbox -- ^ Might be 'postmaster'. + | Data + | Rset + | Send Mailbox + | Soml Mailbox + | Saml Mailbox + | Vrfy String + | Expn String + | Help String -- ^ Might be @[]@. + | Noop -- ^ Optional argument ignored. + | Quit + | Turn + | WrongArg String ParseError + -- ^ When a valid command has been recognized, but the + -- argument parser fails, then this type will be + -- returned. The 'String' contains the name of the + -- command (in all upper-case) and the 'ParseError' + -- is, obviously, the error description. + +instance Show SmtpCmd where + show (Helo str) = "HELO " ++ str + show (Ehlo str) = "EHLO " ++ str + show (MailFrom mbox) = "MAIL FROM:" ++ show mbox + show (RcptTo mbox) = "RCPT TO:" ++ show mbox + show Data = "DATA" + show Rset = "RSET" + show (Send mbox) = "SEND " ++ show mbox + show (Soml mbox) = "SOML " ++ show mbox + show (Saml mbox) = "SAML " ++ show mbox + show (Vrfy str) = "VRFY " ++ str + show (Expn str) = "EXPN " ++ str + show Noop = "NOOP" + show Quit = "QUIT" + show Turn = "TURN" + show (Help t) + | null t = "HELP" + | otherwise = "HELP " ++ t + show (WrongArg str _) = "Syntax error in argument of " ++ str ++ "." + +-- |The most general e-mail address has the form: +-- @\<[\@route,...:]user\@domain\>@. This type, too, +-- supports 'show' and 'read'. Note that a \"shown\" address +-- is /always/ enclosed in angular brackets. When comparing +-- two mailboxes for equality, the hostname is case-insensitive. + +data Mailbox = Mailbox [String] String String + +instance Eq Mailbox where + lhs == rhs = norm lhs == norm rhs + where + norm (Mailbox rt lp hp) = (rt, lp, map toLower hp) + +instance Show Mailbox where + show (Mailbox [] [] []) = "<>" + show (Mailbox [] "postmaster" []) = "" + 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 SMTP Replies +---------------------------------------------------------------------- + +-- |An SMTP reply is a three-digit return code plus some waste of +-- bandwidth called \"comments\". This is what the list of strings is +-- for; one string per line in the reply. 'show' will append an +-- \"@\\r\\n@\" end-of-line marker to each entry in that list, so that +-- the resulting string is ready to be sent back to the peer. For +-- example: +-- +-- >>> show $ Reply (Code Success MailSystem 0) ["worked", "like", "a charm" ] +-- "250-worked\r\n250-like\r\n250 a charm\r\n" +-- +-- If the message is an empty list @[]@, a default text will be constructed: +-- +-- >>> show $ Reply (Code Success MailSystem 0) [] +-- "250 Success in category MailSystem\r\n" + +data SmtpReply = Reply SmtpCode [String] + +data SmtpCode = Code SuccessCode Category Int + +data SuccessCode + = Unused0 + | PreliminarySuccess + | Success + | IntermediateSuccess + | TransientFailure + | PermanentFailure + deriving (Enum, Bounded, Eq, Ord, Show) + +data Category + = Syntax + | Information + | Connection + | Unspecified3 + | Unspecified4 + | MailSystem + deriving (Enum, Bounded, Eq, Ord, Show) + +instance Show SmtpReply where + show (Reply c@(Code suc cat _) []) = + let msg = show suc ++ " in category " ++ show cat + in + show $ Reply c [msg] + + show (Reply code msg) = + let prefixCon = show code ++ "-" + prefixEnd = show code ++ " " + fmt p l = p ++ l ++ "\r\n" + (x:xs) = reverse msg + msgCon = map (fmt prefixCon) xs + msgEnd = fmt prefixEnd x + msg' = reverse (msgEnd:msgCon) + in + concat msg' + +instance Show SmtpCode where + show (Code suc cat n) = + assert (n >= 0 && n <= 9) $ + (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n + +-- |Construct a 'Reply'. Fails 'assert' if invalid numbers +-- are given. + +reply :: Int -> Int -> Int -> [String] -> SmtpReply +reply suc c n msg = + assert (suc >= 0 && suc <= 5) $ + assert (c >= 0 && c <= 5) $ + assert (n >= 0 && n <= 9) $ + Reply (Code (toEnum suc) (toEnum c) n) msg + +-- |A reply constitutes \"success\" if the status code is +-- any of 'PreliminarySuccess', 'Success', or +-- 'IntermediateSuccess'. + +isSuccess :: SmtpReply -> Bool +isSuccess (Reply (Code PreliminarySuccess _ _) _) = True +isSuccess (Reply (Code Success _ _) _) = True +isSuccess (Reply (Code IntermediateSuccess _ _) _) = True +isSuccess _ = False + +-- |A reply constitutes \"failure\" if the status code is +-- either 'PermanentFailure' or 'TransientFailure'. + +isFailure :: SmtpReply -> Bool +isFailure (Reply (Code PermanentFailure _ _) _) = True +isFailure (Reply (Code TransientFailure _ _) _) = True +isFailure _ = False + +-- |The replies @221@ and @421@ signify 'Shutdown'. + +isShutdown :: SmtpReply -> Bool +isShutdown (Reply (Code Success Connection 1) _) = True +isShutdown (Reply (Code TransientFailure Connection 1) _) = True +isShutdown _ = False + +---------------------------------------------------------------------- +-- * Command Parsers +---------------------------------------------------------------------- + +-- |The SMTP parsers defined here correspond to the commands +-- specified in RFC2821, so I won't document them +-- individually. + +-- type SmtpParser s u m = Stream s m Char => ParsecT s u m SmtpCmd + +-- |This parser recognizes any of the SMTP commands defined +-- below. Note that /all/ command parsers expect their input +-- to be terminated with 'crlf'. + +smtpCmd :: Stream s m Char => ParsecT s u m SmtpCmd +smtpCmd = choice + [ smtpData, rset, noop, quit, turn + , helo, mail, rcpt, send, soml, saml + , vrfy, expn, help, ehlo + ] + +-- |The parser name \"data\" was taken. +smtpData :: Stream s m Char => ParsecT s u m SmtpCmd +rset, quit, turn, helo, ehlo, mail :: Stream s m Char => ParsecT s u m SmtpCmd +rcpt, send, soml, saml, vrfy, expn :: Stream s m Char => ParsecT s u m SmtpCmd +help :: Stream s m Char => ParsecT s u m SmtpCmd + +-- |May have an optional 'word' argument, but it is ignored. +noop :: Stream s m Char => ParsecT s u m SmtpCmd + +smtpData = mkCmd0 "DATA" Data +rset = mkCmd0 "RSET" Rset +quit = mkCmd0 "QUIT" Quit +turn = mkCmd0 "TURN" Turn +helo = mkCmd1 "HELO" Helo domain +ehlo = mkCmd1 "EHLO" Ehlo domain +mail = mkCmd1 "MAIL" MailFrom from_path +rcpt = mkCmd1 "RCPT" RcptTo to_path +send = mkCmd1 "SEND" Send from_path +soml = mkCmd1 "SOML" Soml from_path +saml = mkCmd1 "SAML" Saml from_path +vrfy = mkCmd1 "VRFY" Vrfy word +expn = mkCmd1 "EXPN" Expn word + +help = try (mkCmd0 "HELP" (Help [])) <|> + mkCmd1 "HELP" Help (option [] word) + +noop = try (mkCmd0 "NOOP" Noop) <|> + mkCmd1 "NOOP" (const Noop) (option [] word) + + +---------------------------------------------------------------------- +-- * Argument Parsers +---------------------------------------------------------------------- + +from_path :: Stream s m Char => ParsecT s u m Mailbox +from_path = do + caseString "from:" + (try (string "<>" >> return nullPath) <|> path) + "from-path" + +to_path :: Stream s m Char => ParsecT s u m Mailbox +to_path = do + caseString "to:" + (try (caseString "" >> return postmaster) + <|> path) "to-path" + +path :: Stream s m Char => ParsecT s u m Mailbox +path = between (char '<') (char '>') (p "path") + where + p = do + r1 <- option [] (a_d_l >>= \r -> char ':' >> return r) + (Mailbox _ l d) <- mailbox + return (Mailbox r1 l d) + +mailbox :: Stream s m Char => ParsecT s u m Mailbox +mailbox = p "mailbox" + where + p = do + r1 <- local_part + _ <- char '@' + r2 <- domain + return (Mailbox [] r1 r2) + +local_part :: Stream s m Char => ParsecT s u m String +local_part = (dot_string <|> quoted_string) "local-part" + +domain :: Stream s m Char => ParsecT s u m String +domain = choice + [ tokenList subdomain '.' "domain" + , address_literal "address literal" + ] + +a_d_l :: Stream s m Char => ParsecT s u m [String] +a_d_l = sepBy1 at_domain (char ',') "route-list" + +at_domain :: Stream s m Char => ParsecT s u m String +at_domain = (char '@' >> domain) "at-domain" + +-- |/TODO/: Add IPv6 address and general literals +address_literal :: Stream s m Char => ParsecT s u m String +address_literal = ipv4_literal "IPv4 address literal" + +ipv4_literal :: Stream s m Char => ParsecT s u m String +ipv4_literal = do + rs <- between (char '[') (char ']') ipv4addr + return ('[': reverse (']': reverse rs)) + +ipv4addr :: Stream s m Char => ParsecT s u m String +ipv4addr = p "IPv4 address literal" + where + p = do + r1 <- snum + r2 <- char '.' >> snum + r3 <- char '.' >> snum + r4 <- char '.' >> snum + return (r1 ++ "." ++ r2 ++ "." ++ r3 ++ "." ++ r4) + +subdomain :: Stream s m Char => ParsecT s u m String +subdomain = p "domain name" + where + p = do + r <- many1 (alpha <|> digit <|> char '-') + if last r == '-' + then fail "subdomain must not end with hyphen" + else return r + +dot_string :: Stream s m Char => ParsecT s u m String +dot_string = tokenList atom '.' "dot_string" + +atom :: Stream s m Char => ParsecT s u m String +atom = many1 atext "atom" + where + atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" + +snum :: Stream s m Char => ParsecT s u m String +snum = do + r <- manyNtoM 1 3 digit + if (read r :: Int) > 255 + then fail "IP address parts must be 0 <= x <= 255" + else return r + +number :: Stream s m Char => ParsecT s u m String +number = many1 digit + +-- |This is a useful addition: The parser accepts an 'atom' +-- or a 'quoted_string'. + +word :: Stream s m Char => ParsecT s u m String +word = (atom <|> fmap show quoted_string) + "word or quoted-string" + + +---------------------------------------------------------------------- +-- * Helper Functions +---------------------------------------------------------------------- + +-- |Make the string 'crlf' terminated no matter what. +-- \'@\\n@\' is expanded, otherwise 'crlf' is appended. Note +-- that if the string was terminated incorrectly before, it +-- still is. This function is useful when reading input with +-- 'System.IO.hGetLine' which removes the end-of-line +-- delimiter. + +fixCRLF :: String -> String +fixCRLF ('\r' :'\n':[]) = fixCRLF [] +fixCRLF ( x :'\n':[]) = x : fixCRLF [] +fixCRLF ( x : xs ) = x : fixCRLF xs +fixCRLF [ ] = "\r\n" + +-- |Construct a parser for a command without arguments. +-- Expects 'crlf'! + +mkCmd0 :: Stream s m Char => String -> a -> ParsecT s u m a +mkCmd0 str cons = (do + try (caseString str) + _ <- skipMany wsp >> crlf + return cons) str + +-- |Construct a parser for a command with an argument, which +-- the given parser will handle. The result of the argument +-- parser will be applied to the type constructor before it +-- is returned. Expects 'crlf'! + +mkCmd1 :: Stream s m Char => String -> (a -> SmtpCmd) -> ParsecT s u m a + -> ParsecT s u m SmtpCmd +mkCmd1 str cons p = do + try (caseString str) + _ <- wsp + input <- getInput + st <- getState + let eol = skipMany wsp >> crlf + p' = between (many wsp) eol p str + r <- lift $ runParserT p' st "" input + case r of + Left e -> return (WrongArg str e) + Right a -> return (cons a) + +-- @tokenList p '.'@ will parse a token of the form +-- \"@p.p@\", or \"@p.p.p@\", and so on. Used in 'domain' +-- and 'dot_string', for example. + +tokenList :: Stream s m Char => ParsecT s u m String -> Char + -> ParsecT s u m String +tokenList p c = fmap (intercalate [c]) (sepBy1 p (char c)) diff --git a/src/Text/Parsec/Rfc2822.hs b/src/Text/Parsec/Rfc2822.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Rfc2822.hs @@ -0,0 +1,1404 @@ +{-# LANGUAGE FlexibleContexts #-} +{- | + Module : Text.Parsec.Rfc2822 + Copyright : (c) 2013 Peter Simons + License : BSD3 + + Maintainer : simons@cryp.to + Stability : provisional + Portability : portable + + This module provides parsers for the grammar defined in + RFC2822, \"Internet Message Format\", + . +-} + +module Text.Parsec.Rfc2822 where + +import Text.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string ) + +import Control.Monad ( replicateM ) +import Data.Char ( ord ) +import Data.List ( intercalate ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid, mempty ) +import System.Time +import Text.Parsec hiding (crlf) + +-- Customize hlint ... +{-# ANN module "HLint: ignore Use camelCase" #-} + +-- * Useful parser combinators + +-- |Return @Nothing@ if the given parser doesn't match. This +-- combinator is included in the latest parsec distribution as +-- @optionMaybe@, but ghc-6.6.1 apparently doesn't have it. + +maybeOption :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe a) +maybeOption p = option Nothing (fmap Just p) + +-- |@unfold@ @=@ @between (optional cfws) (optional cfws)@ + +unfold :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a +unfold = between (optional cfws) (optional cfws) + +-- |Construct a parser for a message header line from the +-- header's name and a parser for the body. + +header :: Stream s m Char => String -> ParsecT s u m a -> ParsecT s u m a +header n p = let nameString = caseString (n ++ ":") + in + between nameString crlf p (n ++ " header line") + +-- |Like 'header', but allows the obsolete white-space rules. + +obs_header :: Stream s m Char => String -> ParsecT s u m a -> ParsecT s u m a +obs_header n p = let nameString = caseString n >> many wsp >> char ':' + in + between nameString crlf p ("obsolete " ++ n ++ " header line") + + +-- ** Primitive Tokens (section 3.2.1) + +-- |Match any US-ASCII non-whitespace control character. + +no_ws_ctl :: Stream s m Char => ParsecT s u m Char +no_ws_ctl = satisfy (\c -> ord c `elem` ([1..8] ++ [11,12] ++ [14..31] ++ [127])) + "US-ASCII non-whitespace control character" + +-- |Match any US-ASCII character except for @\r@, @\n@. + +text :: Stream s m Char => ParsecT s u m Char +text = satisfy (\c -> ord c `elem` ([1..9] ++ [11,12] ++ [14..127])) + "US-ASCII character (excluding CR and LF)" + +-- |Match any of the RFC's \"special\" characters: @()\<\>[]:;\@,.\\\"@. + +specials :: Stream s m Char => ParsecT s u m Char +specials = oneOf "()<>[]:;@,.\\\"" "one of ()<>[]:;@,.\\\"" + + +-- ** Quoted characters (section 3.2.2) + +-- |Match a \"quoted pair\". All characters matched by 'text' may be +-- quoted. Note that the parsers returns /both/ characters, the +-- backslash and the actual content. + +quoted_pair :: Stream s m Char => ParsecT s u m String +quoted_pair = try obs_qp <|> do { _ <- char '\\'; r <- text; return ['\\',r] } + "quoted pair" + +-- ** Folding white space and comments (section 3.2.3) + +-- |Match \"folding whitespace\". That is any combination of 'wsp' and +-- 'crlf' followed by 'wsp'. + +fws :: Stream s m Char => ParsecT s u m String +fws = do r <- many1 $ choice [ blanks, linebreak] + return (concat r) + where + blanks = many1 wsp + linebreak = try $ do { r1 <- crlf; r2 <- blanks; return (r1 ++ r2) } + +-- |Match any non-whitespace, non-control character except for \"@(@\", +-- \"@)@\", and \"@\\@\". This is used to describe the legal content of +-- 'comment's. +-- +-- /Note/: This parser accepts 8-bit characters, even though this is +-- not legal according to the RFC. Unfortunately, 8-bit content in +-- comments has become fairly common in the real world, so we'll just +-- accept the fact. + +ctext :: Stream s m Char => ParsecT s u m Char +ctext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33..39] ++ [42..91] ++ [93..126] ++ [128..255])) + "any regular character (excluding '(', ')', and '\\')" + +-- |Match a \"comments\". That is any combination of 'ctext', +-- 'quoted_pair's, and 'fws' between brackets. Comments may nest. + +comment :: Stream s m Char => ParsecT s u m String +comment = do _ <- char '(' + r1 <- many ccontent + r2 <- option [] fws + _ <- char ')' + return ("(" ++ concat r1 ++ r2 ++ ")") + "comment" + where + ccontent = try $ do r1 <- option [] fws + r2 <- choice [many1 ctext, quoted_pair, comment] + return (r1 ++ r2) + +-- |Match any combination of 'fws' and 'comments'. + +cfws :: Stream s m Char => ParsecT s u m String +cfws = do r <- many1 $ choice [ fws, comment ] + return (concat r) + +-- ** Atom (section 3.2.4) + +-- |Match any US-ASCII character except for control characters, +-- 'specials', or space. 'atom' and 'dot_atom' are made up of this. + +atext :: Stream s m Char => ParsecT s u m Char +atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" + "US-ASCII character (excluding controls, space, and specials)" + +-- |Match one or more 'atext' characters and skip any preceeding or +-- trailing 'cfws'. + +atom :: Stream s m Char => ParsecT s u m String +atom = unfold (many1 atext "atom") + +-- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'. + +dot_atom :: Stream s m Char => ParsecT s u m String +dot_atom = unfold (dot_atom_text "dot atom") + +-- |Match two or more 'atext's interspersed by dots. + +dot_atom_text :: Stream s m Char => ParsecT s u m String +dot_atom_text = fmap (intercalate ".") (sepBy1 (many1 atext) (char '.')) + "dot atom content" + + +-- ** Quoted strings (section 3.2.5) + +-- |Match any non-whitespace, non-control US-ASCII character except +-- for \"@\\@\" and \"@\"@\". + +qtext :: Stream s m Char => ParsecT s u m Char +qtext = no_ws_ctl <|> satisfy (\c -> ord c `elem` ([33] ++ [35..91] ++ [93..126])) + "US-ASCII character (excluding '\\', and '\"')" + +-- |Match either 'qtext' or 'quoted_pair'. + +qcontent :: Stream s m Char => ParsecT s u m String +qcontent = many1 qtext <|> quoted_pair + "quoted string content" + +-- |Match any number of 'qcontent' between double quotes. Any 'cfws' +-- preceeding or following the \"atom\" is skipped automatically. + +quoted_string :: Stream s m Char => ParsecT s u m String +quoted_string = unfold (do _ <- dquote + r1 <- many (do r1 <- option [] fws + r2 <- qcontent + return (r1 ++ r2)) + r2 <- option [] fws + _ <- dquote + return ("\"" ++ concat r1 ++ r2 ++ "\"")) + "quoted string" + + +-- * Miscellaneous tokens (section 3.2.6) + +-- |Match either 'atom' or 'quoted_string'. + +word :: Stream s m Char => ParsecT s u m String +word = unfold (atom <|> quoted_string) "word" + +-- |Match either one or more 'word's or an 'obs_phrase'. + +phrase :: Stream s m Char => ParsecT s u m [String] +phrase = {- many1 word "phrase" <|> -} obs_phrase + +-- |Match any non-whitespace, non-control US-ASCII character except +-- for \"@\\@\" and \"@\"@\". + +utext :: Stream s m Char => ParsecT s u m Char +utext = no_ws_ctl <|> satisfy (\c -> ord c `elem` [33..126]) + "regular US-ASCII character (excluding '\\', and '\"')" + +-- |Match any number of 'utext' tokens. +-- +-- \"Unstructured text\" is used in free text fields such as 'subject'. +-- Please note that any comments or whitespace that prefaces or +-- follows the actual 'utext' is /included/ in the returned string. + +unstructured :: Stream s m Char => ParsecT s u m String +unstructured = do r1 <- option [] fws + r2 <- many (do r3 <- utext + r4 <- option [] fws + return (r3 : r4)) + return (r1 ++ concat r2) + "unstructured text" + + +-- * Date and Time Specification (section 3.3) + +-- |Parse a date and time specification of the form +-- +-- > Thu, 19 Dec 2002 20:35:46 +0200 +-- +-- where the weekday specification \"@Thu,@\" is optional. The parser +-- returns a 'CalendarTime', which is set to the appropriate values. +-- Note, though, that not all fields of 'CalendarTime' will +-- necessarily be set correctly! Obviously, when no weekday has been +-- provided, the parser will set this field to 'Monday' - regardless +-- of whether the day actually is a monday or not. Similarly, the day +-- of the year will always be returned as @0@. The timezone name will +-- always be empty: @\"\"@. +-- +-- Nor will the 'date_time' parser perform /any/ consistency checking. +-- It will accept +-- +-- > 40 Apr 2002 13:12 +0100 +-- +-- as a perfectly valid date. +-- +-- In order to get all fields set to meaningful values, and in order +-- to verify the date's consistency, you will have to feed it into any +-- of the conversion routines provided in "System.Time", such as +-- 'toClockTime'. (When doing this, keep in mind that most functions +-- return /local time/. This will not necessarily be the time you're +-- expecting.) + +date_time :: Stream s m Char => ParsecT s u m CalendarTime +date_time = do wd <- option Monday (try (do wd <- day_of_week + _ <- char ',' + return wd)) + (y,m,d) <- date + _ <- fws + (td,z) <- time + optional cfws + return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False) + "date/time specification" + +-- |This parser matches a 'day_name' or an 'obs_day_of_week' (optionally +-- wrapped in folding whitespace) and return its 'Day' value. + +day_of_week :: Stream s m Char => ParsecT s u m Day +day_of_week = try (between (optional fws) (optional fws) day_name "name of a day-of-the-week") + <|> obs_day_of_week + +-- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...) +-- and return the appropriate 'Day' value. + +day_name :: Stream s m Char => ParsecT s u m Day +day_name = do { caseString "Mon"; return Monday } + <|> do { try (caseString "Tue"); return Tuesday } + <|> do { caseString "Wed"; return Wednesday } + <|> do { caseString "Thu"; return Thursday } + <|> do { caseString "Fri"; return Friday } + <|> do { try (caseString "Sat"); return Saturday } + <|> do { caseString "Sun"; return Sunday } + "name of a day-of-the-week" + +-- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return +-- a tripple of the form (Int,Month,Int) - corresponding to +-- (year,month,day). + +date :: Stream s m Char => ParsecT s u m (Int, Month, Int) +date = do d <- day + m <- month + y <- year + return (y,m,d) + "date specification" + +-- |This parser will match a four digit number and return its integer +-- value. No range checking is performed. + +year :: Stream s m Char => ParsecT s u m Int +year = do y <- manyN 4 digit + return (read y :: Int) + "year" + +-- |This parser will match a 'month_name', optionally wrapped in +-- folding whitespace, or an 'obs_month' and return its 'Month' +-- value. + +month :: Stream s m Char => ParsecT s u m Month +month = try (between (optional fws) (optional fws) month_name "month name") + <|> obs_month + + +-- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...) +-- and return the appropriate 'Month' value. + +month_name :: Stream s m Char => ParsecT s u m Month +month_name = do { try (caseString "Jan"); return January } + <|> do { caseString "Feb"; return February } + <|> do { try (caseString "Mar"); return March } + <|> do { try (caseString "Apr"); return April } + <|> do { caseString "May"; return May } + <|> do { try (caseString "Jun"); return June } + <|> do { caseString "Jul"; return July } + <|> do { caseString "Aug"; return August } + <|> do { caseString "Sep"; return September } + <|> do { caseString "Oct"; return October } + <|> do { caseString "Nov"; return November } + <|> do { caseString "Dec"; return December } + "month name" + +-- Internal helper function: match a 1 or 2-digit number (day of month). + +day_of_month :: Stream s m Char => ParsecT s u m Int +day_of_month = fmap read (manyNtoM 1 2 digit) + +-- |Match a 1 or 2-digit number (day of month), recognizing both +-- standard and obsolete folding syntax. + +day :: Stream s m Char => ParsecT s u m Int +day = try obs_day <|> day_of_month "day" + +-- |This parser will match a 'time_of_day' specification followed by a +-- 'zone'. It returns the tuple (TimeDiff,Int) corresponding to the +-- return values of either parser. + +time :: Stream s m Char => ParsecT s u m (TimeDiff, Int) +time = do t <- time_of_day + _ <- fws + z <- zone + return (t,z) + "time and zone specification" + +-- |This parser will match a time-of-day specification of \"@hh:mm@\" or +-- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'. + +time_of_day :: Stream s m Char => ParsecT s u m TimeDiff +time_of_day = do h <- hour + _ <- char ':' + m <- minute + s <- option 0 (do { _ <- char ':'; second } ) + return (TimeDiff 0 0 0 h m s 0) + "time specification" + +-- |This parser will match a two-digit number and return its integer +-- value. No range checking is performed. + +hour :: Stream s m Char => ParsecT s u m Int +hour = do r <- replicateM 2 digit + return (read r :: Int) + "hour" + +-- |This parser will match a two-digit number and return its integer +-- value. No range checking is performed. + +minute :: Stream s m Char => ParsecT s u m Int +minute = do r <- replicateM 2 digit + return (read r :: Int) + "minute" + +-- |This parser will match a two-digit number and return its integer +-- value. No range checking takes place. + +second :: Stream s m Char => ParsecT s u m Int +second = do r <- replicateM 2 digit + return (read r :: Int) + "second" + +-- |This parser will match a timezone specification of the form +-- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in +-- seconds as an integer. 'obs_zone' is matched as well. + +zone :: Stream s m Char => ParsecT s u m Int +zone = ( do _ <- char '+' + h <- hour + m <- minute + return (((h*60)+m)*60) + <|> do _ <- char '-' + h <- hour + m <- minute + return (-((h*60)+m)*60) + "time zone" + ) + <|> obs_zone + + +-- * Address Specification (section 3.4) + +-- |A NameAddr is composed of an optional realname a mandatory +-- e-mail 'address'. + +data NameAddr = NameAddr { nameAddr_name :: Maybe String + , nameAddr_addr :: String + } + deriving (Show,Eq) + +-- |Parse a single 'mailbox' or an address 'group' and return the +-- address(es). + +address :: Stream s m Char => ParsecT s u m [NameAddr] +address = try (do { r <- mailbox; return [r] }) <|> group + "address" + +-- |Parse a 'name_addr' or an 'addr_spec' and return the +-- address. + +mailbox :: Stream s m Char => ParsecT s u m NameAddr +mailbox = try name_addr <|> fmap (NameAddr Nothing) addr_spec + "mailbox" + +-- |Parse an 'angle_addr', optionally prefaced with a 'display_name', +-- and return the address. + +name_addr :: Stream s m Char => ParsecT s u m NameAddr +name_addr = do name <- maybeOption display_name + addr <- angle_addr + return (NameAddr name addr) + "name address" + +-- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address. + +angle_addr :: Stream s m Char => ParsecT s u m String +angle_addr = try (unfold (do _ <- char '<' + r <- addr_spec + _ <- char '>' + return r) + "angle address" + ) + <|> obs_angle_addr + +-- |Parse a \"group\" of addresses. That is a 'display_name', followed +-- by a colon, optionally followed by a 'mailbox_list', followed by a +-- semicolon. The found address(es) are returned - what may be none. +-- Here is an example: +-- +-- >>> parse group "" "my group: user1@example.org, user2@example.org;" +-- Right [NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user1@example.org"},NameAddr {nameAddr_name = Nothing, nameAddr_addr = "user2@example.org"}] + +group :: Stream s m Char => ParsecT s u m [NameAddr] +group = do _ <- display_name + _ <- char ':' + r <- option [] mailbox_list + _ <- unfold $ char ';' + return r + "address group" + +-- |Parse and return a 'phrase'. + +display_name :: Stream s m Char => ParsecT s u m String +display_name = fmap unwords phrase + "display name" + +-- |Parse a list of 'mailbox' addresses, every two addresses being +-- separated by a comma, and return the list of found address(es). + +mailbox_list :: Stream s m Char => ParsecT s u m [NameAddr] +mailbox_list = sepBy mailbox (char ',') "mailbox list" + +-- |Parse a list of 'address' addresses, every two addresses being +-- separated by a comma, and return the list of found address(es). + +address_list :: Stream s m Char => ParsecT s u m [NameAddr] +address_list = do { r <-sepBy address (char ','); return (concat r) } + "address list" + + +-- ** Addr-spec specification (section 3.4.1) + +-- |Parse an \"address specification\". That is a 'local_part', followed +-- by an \"@\@@\" character, followed by a 'domain'. Return the complete +-- address as 'String', ignoring any whitespace or any comments. + +addr_spec :: Stream s m Char => ParsecT s u m String +addr_spec = do r1 <- local_part + _ <- char '@' + r2 <- domain + return (r1 ++ "@" ++ r2) + "address specification" + +-- |Parse and return a \"local part\" of an 'addr_spec'. That is either +-- a 'dot_atom' or a 'quoted_string'. + +local_part :: Stream s m Char => ParsecT s u m String +local_part = try obs_local_part <|> dot_atom <|> quoted_string + "address' local part" + +-- |Parse and return a \"domain part\" of an 'addr_spec'. That is either +-- a 'dot_atom' or a 'domain_literal'. + +domain :: Stream s m Char => ParsecT s u m String +domain = try obs_domain <|> dot_atom <|> domain_literal + "address' domain part" + +-- |Parse a \"domain literal\". That is a \"@[@\" character, followed by +-- any amount of 'dcontent', followed by a terminating \"@]@\" +-- character. The complete string is returned verbatim. + +domain_literal :: Stream s m Char => ParsecT s u m String +domain_literal = unfold (do _ <- char '[' + r <- many (optional fws >> dcontent) + optional fws + _ <- char ']' + return ("[" ++ concat r ++ "]")) + "domain literal" + +-- |Parse and return any characters that are legal in a +-- 'domain_literal'. That is 'dtext' or a 'quoted_pair'. + +dcontent :: Stream s m Char => ParsecT s u m String +dcontent = many1 dtext <|> quoted_pair + "domain literal content" + +-- |Parse and return any ASCII characters except \"@[@\", \"@]@\", and +-- \"@\\@\". + +dtext :: Stream s m Char => ParsecT s u m Char +dtext = no_ws_ctl + <|> satisfy (\c -> ord c `elem` ([33..90] ++ [94..126])) + "any ASCII character (excluding '[', ']', and '\\')" + + +-- * Overall message syntax (section 3.5) + +-- |This data type repesents a parsed Internet Message as defined in +-- this RFC. It consists of an arbitrary number of header lines, +-- represented in the 'Field' data type, and a message body, which may +-- be empty. + +data GenericMessage a = Message [Field] a deriving Show + +-- |Parse a complete message as defined by this RFC and it broken down +-- into the separate header fields and the message body. Header lines, +-- which contain syntax errors, will not cause the parser to abort. +-- Rather, these headers will appear as 'OptionalField's (which are +-- unparsed) in the resulting 'Message'. A message must be really, +-- really badly broken for this parser to fail. +-- +-- This behaviour was chosen because it is impossible to predict what +-- the user of this module considers to be a fatal error; +-- traditionally, parsers are very forgiving when it comes to Internet +-- messages. +-- +-- If you want to implement a really strict parser, you'll have to put +-- the appropriate parser together yourself. You'll find that this is +-- rather easy to do. Refer to the 'fields' parser for further details. + +message :: (Monoid s, Stream s m Char) => ParsecT s u m (GenericMessage s) +message = do f <- fields + b <- option mempty (do _ <- crlf; body) + return (Message f b) + +-- |A message body is just an unstructured sequence of characters. + +body :: (Monoid s, Monad m) => ParsecT s u m s +body = do v <- getInput + setInput mempty + return v + +-- * Field definitions (section 3.6) + +-- |This data type represents any of the header fields defined in this +-- RFC. Each of the various instances contains with the return value +-- of the corresponding parser. + +data Field = OptionalField String String + | From [NameAddr] + | Sender NameAddr + | ReturnPath String + | ReplyTo [NameAddr] + | To [NameAddr] + | Cc [NameAddr] + | Bcc [NameAddr] + | MessageID String + | InReplyTo [String] + | References [String] + | Subject String + | Comments String + | Keywords [[String]] + | Date CalendarTime + | ResentDate CalendarTime + | ResentFrom [NameAddr] + | ResentSender NameAddr + | ResentTo [NameAddr] + | ResentCc [NameAddr] + | ResentBcc [NameAddr] + | ResentMessageID String + | ResentReplyTo [NameAddr] + | Received ([(String,String)], CalendarTime) + | ObsReceived [(String,String)] + deriving (Show) + +-- |This parser will parse an arbitrary number of header fields as +-- defined in this RFC. For each field, an appropriate 'Field' value +-- is created, all of them making up the 'Field' list that this parser +-- returns. +-- +-- If you look at the implementation of this parser, you will find +-- that it uses Parsec's 'try' modifier around /all/ of the fields. +-- The idea behind this is that fields, which contain syntax errors, +-- fall back to the catch-all 'optional_field'. Thus, this parser will +-- hardly ever return a syntax error -- what conforms with the idea +-- that any message that can possibly be accepted /should/ be. + +fields :: Stream s m Char => ParsecT s u m [Field] +fields = many ( try (do { r <- from; return (From r) }) + <|> try (do { r <- sender; return (Sender r) }) + <|> try (do { r <- return_path; return (ReturnPath r) }) + <|> try (do { r <- reply_to; return (ReplyTo r) }) + <|> try (do { r <- to; return (To r) }) + <|> try (do { r <- cc; return (Cc r) }) + <|> try (do { r <- bcc; return (Bcc r) }) + <|> try (do { r <- message_id; return (MessageID r) }) + <|> try (do { r <- in_reply_to; return (InReplyTo r) }) + <|> try (do { r <- references; return (References r) }) + <|> try (do { r <- subject; return (Subject r) }) + <|> try (do { r <- comments; return (Comments r) }) + <|> try (do { r <- keywords; return (Keywords r) }) + <|> try (do { r <- orig_date; return (Date r) }) + <|> try (do { r <- resent_date; return (ResentDate r) }) + <|> try (do { r <- resent_from; return (ResentFrom r) }) + <|> try (do { r <- resent_sender; return (ResentSender r) }) + <|> try (do { r <- resent_to; return (ResentTo r) }) + <|> try (do { r <- resent_cc; return (ResentCc r) }) + <|> try (do { r <- resent_bcc; return (ResentBcc r) }) + <|> try (do { r <- resent_msg_id; return (ResentMessageID r) }) + <|> try (do { r <- received; return (Received r) }) + -- catch all + <|> (do { (name,cont) <- optional_field; return (OptionalField name cont) }) + ) + + +-- ** The origination date field (section 3.6.1) + +-- |Parse a \"@Date:@\" header line and return the date it contains a +-- 'CalendarTime'. + +orig_date :: Stream s m Char => ParsecT s u m CalendarTime +orig_date = header "Date" date_time + + +-- ** Originator fields (section 3.6.2) + +-- |Parse a \"@From:@\" header line and return the 'mailbox_list' +-- address(es) contained in it. + +from :: Stream s m Char => ParsecT s u m [NameAddr] +from = header "From" mailbox_list + +-- |Parse a \"@Sender:@\" header line and return the 'mailbox' address +-- contained in it. + +sender :: Stream s m Char => ParsecT s u m NameAddr +sender = header "Sender" mailbox + +-- |Parse a \"@Reply-To:@\" header line and return the 'address_list' +-- address(es) contained in it. + +reply_to :: Stream s m Char => ParsecT s u m [NameAddr] +reply_to = header "Reply-To" address_list + + +-- ** Destination address fields (section 3.6.3) + +-- |Parse a \"@To:@\" header line and return the 'address_list' +-- address(es) contained in it. + +to :: Stream s m Char => ParsecT s u m [NameAddr] +to = header "To" address_list + +-- |Parse a \"@Cc:@\" header line and return the 'address_list' +-- address(es) contained in it. + +cc :: Stream s m Char => ParsecT s u m [NameAddr] +cc = header "Cc" address_list + +-- |Parse a \"@Bcc:@\" header line and return the 'address_list' +-- address(es) contained in it. + +bcc :: Stream s m Char => ParsecT s u m [NameAddr] +bcc = header "Bcc" (try address_list <|> do { optional cfws; return [] }) + +-- ** Identification fields (section 3.6.4) + +-- |Parse a \"@Message-Id:@\" header line and return the 'msg_id' +-- contained in it. + +message_id :: Stream s m Char => ParsecT s u m String +message_id = header "Message-ID" msg_id + +-- |Parse a \"@In-Reply-To:@\" header line and return the list of +-- 'msg_id's contained in it. + +in_reply_to :: Stream s m Char => ParsecT s u m [String] +in_reply_to = header "In-Reply-To" (many1 msg_id) + +-- |Parse a \"@References:@\" header line and return the list of +-- 'msg_id's contained in it. + +references :: Stream s m Char => ParsecT s u m [String] +references = header "References" (many1 msg_id) + +-- |Parse a \"@message ID:@\" and return it. A message ID is almost +-- identical to an 'angle_addr', but with stricter rules about folding +-- and whitespace. + +msg_id :: Stream s m Char => ParsecT s u m String +msg_id = unfold (do _ <- char '<' + idl <- id_left + _ <- char '@' + idr <- id_right + _ <- char '>' + return ("<" ++ idl ++ "@" ++ idr ++ ">")) + "message ID" + +-- |Parse a \"left ID\" part of a 'msg_id'. This is almost identical to +-- the 'local_part' of an e-mail address, but with stricter rules +-- about folding and whitespace. + +id_left :: Stream s m Char => ParsecT s u m String +id_left = dot_atom_text <|> no_fold_quote + "left part of an message ID" + +-- |Parse a \"right ID\" part of a 'msg_id'. This is almost identical to +-- the 'domain' of an e-mail address, but with stricter rules about +-- folding and whitespace. + +id_right :: Stream s m Char => ParsecT s u m String +id_right = dot_atom_text <|> no_fold_literal + "right part of an message ID" + +-- |Parse one or more occurences of 'qtext' or 'quoted_pair' and +-- return the concatenated string. This makes up the 'id_left' of a +-- 'msg_id'. + +no_fold_quote :: Stream s m Char => ParsecT s u m String +no_fold_quote = do _ <- dquote + r <- many (many1 qtext <|> quoted_pair) + _ <- dquote + return ("\"" ++ concat r ++ "\"") + "non-folding quoted string" + +-- |Parse one or more occurences of 'dtext' or 'quoted_pair' and +-- return the concatenated string. This makes up the 'id_right' of a +-- 'msg_id'. + +no_fold_literal :: Stream s m Char => ParsecT s u m String +no_fold_literal = do _ <- char '[' + r <- many (many1 dtext <|> quoted_pair) + _ <- char ']' + return ("[" ++ concat r ++ "]") + "non-folding domain literal" + + +-- ** Informational fields (section 3.6.5) + +-- |Parse a \"@Subject:@\" header line and return its contents verbatim. +-- Please note that all whitespace and/or comments are preserved, i.e. +-- the result of parsing @\"Subject: foo\"@ is @\" foo\"@, not @\"foo\"@. + +subject :: Stream s m Char => ParsecT s u m String +subject = header "Subject" unstructured + +-- |Parse a \"@Comments:@\" header line and return its contents verbatim. +-- Please note that all whitespace and/or comments are preserved, i.e. +-- the result of parsing @\"Comments: foo\"@ is @\" foo\"@, not @\"foo\"@. + +comments :: Stream s m Char => ParsecT s u m String +comments = header "Comments" unstructured + +-- |Parse a \"@Keywords:@\" header line and return the list of 'phrase's +-- found. Please not that each phrase is again a list of 'atom's, as +-- returned by the 'phrase' parser. + +keywords :: Stream s m Char => ParsecT s u m [[String]] +keywords = header "Keywords" (do r1 <- phrase + r2 <- many (do _ <- char ','; phrase) + return (r1:r2)) + + +-- ** Resent fields (section 3.6.6) + +-- |Parse a \"@Resent-Date:@\" header line and return the date it +-- contains as 'CalendarTime'. + +resent_date :: Stream s m Char => ParsecT s u m CalendarTime +resent_date = header "Resent-Date" date_time + +-- |Parse a \"@Resent-From:@\" header line and return the 'mailbox_list' +-- address(es) contained in it. + +resent_from :: Stream s m Char => ParsecT s u m [NameAddr] +resent_from = header "Resent-From" mailbox_list + + +-- |Parse a \"@Resent-Sender:@\" header line and return the 'mailbox_list' +-- address(es) contained in it. + +resent_sender :: Stream s m Char => ParsecT s u m NameAddr +resent_sender = header "Resent-Sender" mailbox + + +-- |Parse a \"@Resent-To:@\" header line and return the 'mailbox' +-- address contained in it. + +resent_to :: Stream s m Char => ParsecT s u m [NameAddr] +resent_to = header "Resent-To" address_list + +-- |Parse a \"@Resent-Cc:@\" header line and return the 'address_list' +-- address(es) contained in it. + +resent_cc :: Stream s m Char => ParsecT s u m [NameAddr] +resent_cc = header "Resent-Cc" address_list + +-- |Parse a \"@Resent-Bcc:@\" header line and return the 'address_list' +-- address(es) contained in it. (This list may be empty.) + +resent_bcc :: Stream s m Char => ParsecT s u m [NameAddr] +resent_bcc = header "Resent-Bcc" ( try address_list + <|> do optional cfws + return [] + ) + "Resent-Bcc: header line" + +-- |Parse a \"@Resent-Message-ID:@\" header line and return the 'msg_id' +-- contained in it. + +resent_msg_id :: Stream s m Char => ParsecT s u m String +resent_msg_id = header "Resent-Message-ID" msg_id + + +-- ** Trace fields (section 3.6.7) + +return_path :: Stream s m Char => ParsecT s u m String +return_path = header "Return-Path" path + +path :: Stream s m Char => ParsecT s u m String +path = unfold ( try (do _ <- char '<' + r <- option "" addr_spec + _ <- char '>' + return ("<" ++ r ++ ">") + ) + <|> obs_path + ) + "return path spec" + +received :: Stream s m Char => ParsecT s u m ([(String,String)], CalendarTime) +received = header "Received" (do r1 <- name_val_list + _ <- char ';' + r2 <- date_time + return (r1,r2)) + +name_val_list :: Stream s m Char => ParsecT s u m [(String,String)] +name_val_list = do optional cfws + many1 name_val_pair + "list of name/value pairs" + +name_val_pair :: Stream s m Char => ParsecT s u m (String,String) +name_val_pair = do r1 <- item_name + _ <- cfws + r2 <- item_value + return (r1,r2) + "a name/value pair" + +item_name :: Stream s m Char => ParsecT s u m String +item_name = do r1 <- alpha + r2 <- many $ choice [ char '-', alpha, digit ] + return (r1 : r2) + "name of a name/value pair" + +item_value :: Stream s m Char => ParsecT s u m String +item_value = choice [ try (do { r <- many1 angle_addr; return (concat r) }) + , try addr_spec + , try domain + , msg_id + , try atom + ] + "value of a name/value pair" + +-- ** Optional fields (section 3.6.8) + +-- |Parse an arbitrary header field and return a tuple containing the +-- 'field_name' and 'unstructured' text of the header. The name will +-- /not/ contain the terminating colon. + +optional_field :: Stream s m Char => ParsecT s u m (String,String) +optional_field = do n <- field_name + _ <- char ':' + b <- unstructured + _ <- crlf + return (n,b) + "optional (unspecified) header line" + +-- |Parse and return an arbitrary header field name. That is one or +-- more 'ftext' characters. + +field_name :: Stream s m Char => ParsecT s u m String +field_name = many1 ftext "header line name" + +-- |Match and return any ASCII character except for control +-- characters, whitespace, and \"@:@\". + +ftext :: Stream s m Char => ParsecT s u m Char +ftext = satisfy (\c -> ord c `elem` ([33..57] ++ [59..126])) + "character (excluding controls, space, and ':')" + + +-- * Miscellaneous obsolete tokens (section 4.1) + +-- |Match the obsolete \"quoted pair\" syntax, which - unlike +-- 'quoted_pair' - allowed /any/ ASCII character to be specified when +-- quoted. The parser will return both, the backslash and the actual +-- character. + +obs_qp :: Stream s m Char => ParsecT s u m String +obs_qp = do _ <- char '\\' + c <- satisfy (\c -> ord c `elem` [0..127]) + return ['\\',c] + "any quoted US-ASCII character" + +-- |Match the obsolete \"text\" syntax, which - unlike 'text' - allowed +-- \"carriage returns\" and \"linefeeds\". This is really weird; you +-- better consult the RFC for details. The parser will return the +-- complete string, including those special characters. + +obs_text :: Stream s m Char => ParsecT s u m String +obs_text = do r1 <- many lf + r2 <- many cr + r3 <- many (do r4 <- obs_char + r5 <- many lf + r6 <- many cr + return (r4 : (r5 ++ r6))) + return (r1 ++ r2 ++ concat r3) + +-- |Match and return the obsolete \"char\" syntax, which - unlike +-- 'character' - did not allow \"carriage return\" and \"linefeed\". + +obs_char :: Stream s m Char => ParsecT s u m Char +obs_char = satisfy (\c -> ord c `elem` ([0..9] ++ [11,12] ++ [14..127])) + "any ASCII character except CR and LF" + +-- |Match and return the obsolete \"utext\" syntax, which is identical +-- to 'obs_text'. + +obs_utext :: Stream s m Char => ParsecT s u m String +obs_utext = obs_text + +-- |Match the obsolete \"phrase\" syntax, which - unlike 'phrase' - +-- allows dots between tokens. + +obs_phrase :: Stream s m Char => ParsecT s u m [String] +obs_phrase = do r1 <- word + r2 <- many $ choice [ word + , string "." + , do { _ <- cfws; return [] } + ] + return (r1 : filter (/=[]) r2) + +-- |Match a \"phrase list\" syntax and return the list of 'String's +-- that make up the phrase. In contrast to a 'phrase', the +-- 'obs_phrase_list' separates the individual words by commas. This +-- syntax is - as you will have guessed - obsolete. + +obs_phrase_list :: Stream s m Char => ParsecT s u m [String] +obs_phrase_list = do r1 <- many1 (do r <- option [] phrase + _ <- unfold $ char ',' + return (filter (/=[]) r)) + r2 <- option [] phrase + return (concat r1 ++ r2) + <|> phrase + + +-- * Obsolete folding white space (section 4.2) + +-- |Parse and return an \"obsolete fws\" token. That is at least one +-- 'wsp' character, followed by an arbitrary number (including zero) +-- of 'crlf' followed by at least one more 'wsp' character. + +obs_fws :: Stream s m Char => ParsecT s u m String +obs_fws = do r1 <- many1 wsp + r2 <- many (do r3 <- crlf + r4 <- many1 wsp + return (r3 ++ r4)) + return (r1 ++ concat r2) + + +-- * Obsolete Date and Time (section 4.3) + +-- |Parse a 'day_name' but allow for the obsolete folding syntax. + +obs_day_of_week :: Stream s m Char => ParsecT s u m Day +obs_day_of_week = unfold day_name "day-of-the-week name" + +-- |Parse a 'year' but allow for a two-digit number (obsolete) and the +-- obsolete folding syntax. + +obs_year :: Stream s m Char => ParsecT s u m Int +obs_year = unfold (do r <- manyN 2 digit + return (normalize (read r :: Int))) + "year" + where + normalize n + | n <= 49 = 2000 + n + | n <= 999 = 1900 + n + | otherwise = n + +-- |Parse a 'month_name' but allow for the obsolete folding syntax. + +obs_month :: Stream s m Char => ParsecT s u m Month +obs_month = between cfws cfws month_name "month name" + +-- |Parse a 'day' but allow for the obsolete folding syntax. + +obs_day :: Stream s m Char => ParsecT s u m Int +obs_day = unfold day_of_month "day" + +-- |Parse a 'hour' but allow for the obsolete folding syntax. + +obs_hour :: Stream s m Char => ParsecT s u m Int +obs_hour = unfold hour "hour" + +-- |Parse a 'minute' but allow for the obsolete folding syntax. + +obs_minute :: Stream s m Char => ParsecT s u m Int +obs_minute = unfold minute "minute" + +-- |Parse a 'second' but allow for the obsolete folding syntax. + +obs_second :: Stream s m Char => ParsecT s u m Int +obs_second = unfold second "second" + +-- |Match the obsolete zone names and return the appropriate offset. + +obs_zone :: Stream s m Char => ParsecT s u m Int +obs_zone = choice [ mkZone "UT" 0 + , mkZone "GMT" 0 + , mkZone "EST" (-5) + , mkZone "EDT" (-4) + , mkZone "CST" (-6) + , mkZone "CDT" (-5) + , mkZone "MST" (-7) + , mkZone "MDT" (-6) + , mkZone "PST" (-8) + , mkZone "PDT" (-7) + , do { r <- oneOf ['A'..'I']; return $ (ord r - 64) * 60*60 } "military zone spec" + , do { r <- oneOf ['K'..'M']; return $ (ord r - 65) * 60*60 } "military zone spec" + , do { r <- oneOf ['N'..'Y']; return $ -(ord r - 77) * 60*60 } "military zone spec" + , do { _ <- char 'Z'; return 0 } "military zone spec" + ] + where mkZone n o = try $ do { _ <- string n; return (o*60*60) } + + +-- * Obsolete Addressing (section 4.4) + +-- |This parser matches the \"obsolete angle address\" syntax, a construct that +-- used to be called \"route address\" in earlier RFCs. It differs from a +-- standard 'angle_addr' in two ways: (1) it allows far more +-- liberal insertion of folding whitespace and comments and (2) the address may +-- contain a \"route\" (which this parser ignores): +-- +-- >>> parse obs_angle_addr "" "<@example1.org,@example2.org:joe@example.org>" +-- Right "" + +obs_angle_addr :: Stream s m Char => ParsecT s u m String +obs_angle_addr = unfold (do _ <- char '<' + _ <- option [] obs_route + addr <- addr_spec + _ <- char '>' + return ("<" ++ addr ++ ">") -- TODO: route is lost here. + ) + "obsolete angle address" + +-- |This parser parses the \"route\" part of 'obs_angle_addr' and +-- returns the list of 'String's that make up this route. Relies on +-- 'obs_domain_list' for the actual parsing. + +obs_route :: Stream s m Char => ParsecT s u m [String] +obs_route = unfold (do { r <- obs_domain_list; _ <- char ':'; return r }) + "route of an obsolete angle address" + +-- |This parser parses a list of domain names, each of them prefaced +-- with an \"at\". Multiple names are separated by a comma. The list of +-- 'domain's is returned - and may be empty. + +obs_domain_list :: Stream s m Char => ParsecT s u m [String] +obs_domain_list = do _ <- char '@' + r1 <- domain + r2 <- many (do _ <- cfws <|> string "," + optional cfws + _ <- char '@' + domain) + return (r1 : r2) + "route of an obsolete angle address" + +-- |Parse the obsolete syntax of a 'local_part', which allowed for +-- more liberal insertion of folding whitespace and comments. The +-- actual string is returned. + +obs_local_part :: Stream s m Char => ParsecT s u m String +obs_local_part = do r1 <- word + r2 <- many (do _ <- string "." + r <- word + return ('.' : r)) + return (r1 ++ concat r2) + "local part of an address" + +-- |Parse the obsolete syntax of a 'domain', which allowed for more +-- liberal insertion of folding whitespace and comments. The actual +-- string is returned. + +obs_domain :: Stream s m Char => ParsecT s u m String +obs_domain = do r1 <- atom + r2 <- many (do _ <- string "." + r <- atom + return ('.' : r)) + return (r1 ++ concat r2) + "domain part of an address" + +-- |This parser will match the obsolete syntax for a 'mailbox_list'. +-- This one is quite weird: An 'obs_mbox_list' contains an arbitrary +-- number of 'mailbox'es - including none -, which are separated by +-- commas. But you may have multiple consecutive commas without giving +-- a 'mailbox'. You may also have a valid 'obs_mbox_list' that +-- contains /no/ 'mailbox' at all. On the other hand, you /must/ have +-- at least one comma. The following example is valid: +-- +-- >>> parse obs_mbox_list "" "," +-- Right [] +-- +-- But this one is not: +-- +-- >>> parse obs_mbox_list "" "joe@example.org" +-- Left (line 1, column 16): +-- unexpected end of input +-- expecting obsolete syntax for a list of mailboxes + +obs_mbox_list :: Stream s m Char => ParsecT s u m [NameAddr] +obs_mbox_list = do r1 <- many1 (try (do r <- maybeOption mailbox + _ <- unfold $ char ',' + return r)) + r2 <- maybeOption mailbox + return (catMaybes (r1 ++ [r2])) + "obsolete syntax for a list of mailboxes" + +-- |This parser is identical to 'obs_mbox_list' but parses a list of +-- 'address'es rather than 'mailbox'es. The main difference is that an +-- 'address' may contain 'group's. Please note that as of now, the +-- parser will return a simple list of addresses; the grouping +-- information is lost. + +obs_addr_list :: Stream s m Char => ParsecT s u m [NameAddr] +obs_addr_list = do r1 <- many1 (try (do r <- maybeOption address + optional cfws + _ <- char ',' + optional cfws + return r)) + r2 <- maybeOption address + return (concat (catMaybes (r1 ++ [r2]))) + "obsolete syntax for a list of addresses" + + +-- * Obsolete header fields (section 4.5) + +obs_fields :: Stream s m Char => ParsecT s u m [Field] +obs_fields = many ( try (do { r <- obs_from; return (From r) }) + <|> try (do { r <- obs_sender; return (Sender r) }) + <|> try (do { r <- obs_return; return (ReturnPath r) }) + <|> try (do { r <- obs_reply_to; return (ReplyTo r) }) + <|> try (do { r <- obs_to; return (To r) }) + <|> try (do { r <- obs_cc; return (Cc r) }) + <|> try (do { r <- obs_bcc; return (Bcc r) }) + <|> try (do { r <- obs_message_id; return (MessageID r) }) + <|> try (do { r <- obs_in_reply_to; return (InReplyTo r) }) + <|> try (do { r <- obs_references; return (References r) }) + <|> try (do { r <- obs_subject; return (Subject r) }) + <|> try (do { r <- obs_comments; return (Comments r) }) + <|> try (do { r <- obs_keywords; return (Keywords [r]) }) + <|> try (do { r <- obs_orig_date; return (Date r) }) + <|> try (do { r <- obs_resent_date; return (ResentDate r) }) + <|> try (do { r <- obs_resent_from; return (ResentFrom r) }) + <|> try (do { r <- obs_resent_send; return (ResentSender r) }) + <|> try (do { r <- obs_resent_to; return (ResentTo r) }) + <|> try (do { r <- obs_resent_cc; return (ResentCc r) }) + <|> try (do { r <- obs_resent_bcc; return (ResentBcc r) }) + <|> try (do { r <- obs_resent_mid; return (ResentMessageID r) }) + <|> try (do { r <- obs_resent_reply; return (ResentReplyTo r) }) + <|> try (do { r <- obs_received; return (ObsReceived r) }) + -- catch all + <|> (do { (name,cont) <- obs_optional; return (OptionalField name cont) }) + ) + + +-- ** Obsolete origination date field (section 4.5.1) + +-- |Parse a 'date' header line but allow for the obsolete +-- folding syntax. + +obs_orig_date :: Stream s m Char => ParsecT s u m CalendarTime +obs_orig_date = obs_header "Date" date_time + + +-- ** Obsolete originator fields (section 4.5.2) + +-- |Parse a 'from' header line but allow for the obsolete +-- folding syntax. + +obs_from :: Stream s m Char => ParsecT s u m [NameAddr] +obs_from = obs_header "From" mailbox_list + +-- |Parse a 'sender' header line but allow for the obsolete +-- folding syntax. + +obs_sender :: Stream s m Char => ParsecT s u m NameAddr +obs_sender = obs_header "Sender" mailbox + +-- |Parse a 'reply_to' header line but allow for the obsolete +-- folding syntax. + +obs_reply_to :: Stream s m Char => ParsecT s u m [NameAddr] +obs_reply_to = obs_header "Reply-To" mailbox_list + + +-- ** Obsolete destination address fields (section 4.5.3) + +-- |Parse a 'to' header line but allow for the obsolete +-- folding syntax. + +obs_to :: Stream s m Char => ParsecT s u m [NameAddr] +obs_to = obs_header "To" address_list + +-- |Parse a 'cc' header line but allow for the obsolete +-- folding syntax. + +obs_cc :: Stream s m Char => ParsecT s u m [NameAddr] +obs_cc = obs_header "Cc" address_list + +-- |Parse a 'bcc' header line but allow for the obsolete +-- folding syntax. + +obs_bcc :: Stream s m Char => ParsecT s u m [NameAddr] +obs_bcc = header "Bcc" ( try address_list + <|> do { optional cfws; return [] } + ) + + +-- ** Obsolete identification fields (section 4.5.4) + +-- |Parse a 'message_id' header line but allow for the obsolete +-- folding syntax. + +obs_message_id :: Stream s m Char => ParsecT s u m String +obs_message_id = obs_header "Message-ID" msg_id + +-- |Parse an 'in_reply_to' header line but allow for the obsolete +-- folding and the obsolete phrase syntax. + +obs_in_reply_to :: Stream s m Char => ParsecT s u m [String] +obs_in_reply_to = obs_header "In-Reply-To" (do r <- many ( do {_ <- phrase; return [] } + <|> msg_id + ) + return (filter (/=[]) r)) + +-- |Parse a 'references' header line but allow for the obsolete +-- folding and the obsolete phrase syntax. + +obs_references :: Stream s m Char => ParsecT s u m [String] +obs_references = obs_header "References" (do r <- many ( do { _ <- phrase; return [] } + <|> msg_id + ) + return (filter (/=[]) r)) + +-- |Parses the \"left part\" of a message ID, but allows the obsolete +-- syntax, which is identical to a 'local_part'. + +obs_id_left :: Stream s m Char => ParsecT s u m String +obs_id_left = local_part "left part of an message ID" + +-- |Parses the \"right part\" of a message ID, but allows the obsolete +-- syntax, which is identical to a 'domain'. + +obs_id_right :: Stream s m Char => ParsecT s u m String +obs_id_right = domain "right part of an message ID" + + + +-- ** Obsolete informational fields (section 4.5.5) + +-- |Parse a 'subject' header line but allow for the obsolete +-- folding syntax. + +obs_subject :: Stream s m Char => ParsecT s u m String +obs_subject = obs_header "Subject" unstructured + +-- |Parse a 'comments' header line but allow for the obsolete +-- folding syntax. + +obs_comments :: Stream s m Char => ParsecT s u m String +obs_comments = obs_header "Comments" unstructured + +-- |Parse a 'keywords' header line but allow for the obsolete +-- folding syntax. Also, this parser accepts 'obs_phrase_list'. + +obs_keywords :: Stream s m Char => ParsecT s u m [String] +obs_keywords = obs_header "Keywords" obs_phrase_list + + +-- ** Obsolete resent fields (section 4.5.6) + +-- |Parse a 'resent_from' header line but allow for the obsolete +-- folding syntax. + +obs_resent_from :: Stream s m Char => ParsecT s u m [NameAddr] +obs_resent_from = obs_header "Resent-From" mailbox_list + +-- |Parse a 'resent_sender' header line but allow for the obsolete +-- folding syntax. + +obs_resent_send :: Stream s m Char => ParsecT s u m NameAddr +obs_resent_send = obs_header "Resent-Sender" mailbox + +-- |Parse a 'resent_date' header line but allow for the obsolete +-- folding syntax. + +obs_resent_date :: Stream s m Char => ParsecT s u m CalendarTime +obs_resent_date = obs_header "Resent-Date" date_time + +-- |Parse a 'resent_to' header line but allow for the obsolete +-- folding syntax. + +obs_resent_to :: Stream s m Char => ParsecT s u m [NameAddr] +obs_resent_to = obs_header "Resent-To" mailbox_list + +-- |Parse a 'resent_cc' header line but allow for the obsolete +-- folding syntax. + +obs_resent_cc :: Stream s m Char => ParsecT s u m [NameAddr] +obs_resent_cc = obs_header "Resent-Cc" mailbox_list + +-- |Parse a 'resent_bcc' header line but allow for the obsolete +-- folding syntax. + +obs_resent_bcc :: Stream s m Char => ParsecT s u m [NameAddr] +obs_resent_bcc = obs_header "Bcc" ( try address_list + <|> do { optional cfws; return [] } + ) + +-- |Parse a 'resent_msg_id' header line but allow for the obsolete +-- folding syntax. + +obs_resent_mid :: Stream s m Char => ParsecT s u m String +obs_resent_mid = obs_header "Resent-Message-ID" msg_id + +-- |Parse a @Resent-Reply-To@ header line but allow for the +-- obsolete folding syntax. + +obs_resent_reply :: Stream s m Char => ParsecT s u m [NameAddr] +obs_resent_reply = obs_header "Resent-Reply-To" address_list + + +-- ** Obsolete trace fields (section 4.5.7) + +obs_return :: Stream s m Char => ParsecT s u m String +obs_return = obs_header "Return-Path" path + +obs_received :: Stream s m Char => ParsecT s u m [(String, String)] +obs_received = obs_header "Received" name_val_list + +-- |Match 'obs_angle_addr'. + +obs_path :: Stream s m Char => ParsecT s u m String +obs_path = obs_angle_addr + +-- |This parser is identical to 'optional_field' but allows the more +-- liberal line-folding syntax between the \"field_name\" and the \"field +-- text\". + +obs_optional :: Stream s m Char => ParsecT s u m (String,String) +obs_optional = do n <- field_name + _ <- many wsp + _ <- char ':' + b <- unstructured + _ <- crlf + return (n,b) + "optional (unspecified) header line" diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,6 @@ +module Main ( main ) where + +import Test.DocTest + +main :: IO () +main = doctest [ "-isrc", "src" ] diff --git a/test/spec.hs b/test/spec.hs new file mode 100644 --- /dev/null +++ b/test/spec.hs @@ -0,0 +1,297 @@ +module Main ( main ) where + +import Test.Hspec +import System.Time ( CalendarTime(..), Month(..), Day(..) ) +import Text.Parsec ( parse, eof ) +import Text.Parsec.String ( Parser ) +import Text.Parsec.Rfc2822 + +parseTest :: Parser a -> String -> IO a +parseTest p input = case parse (do { r <- p; eof; return r }) (show input) input of + Left err -> fail ("parse error at " ++ show err) + Right r -> return r + +parseIdemTest :: Parser String -> String -> Expectation +parseIdemTest p input = parseTest p input `shouldReturn` input + +parseFailure :: (Show a) => Parser a -> String -> Expectation +parseFailure p input = parse (do { r <- p; eof; return r }) (show input) input `shouldSatisfy` failure + where + failure (Left _) = True + failure _ = False + +main :: IO () +main = hspec $ do + describe "Rfc2822.quoted_pair" $ + it "can quote a nul byte" $ + parseIdemTest quoted_pair "\\\0" + + describe "Rfc2822.date_time" $ + it "parses hand-picked times correctly" $ + parseTest date_time "Fri, 21 Dec 2012 00:07:43 +0300" `shouldReturn` + CalendarTime 2012 December 21 0 7 43 0 Friday 0 "" 10800 False + + describe "Rfc2822.day" $ do + it "parses a hand-picked day-of-months correctly" $ do + parseTest day "00" `shouldReturn` 0 + parseTest day "09" `shouldReturn` 9 + parseTest day "15" `shouldReturn` 15 + + it "does not perform range checking" $ + parseTest day "99" `shouldReturn` 99 + + it "fails properly on incomplete input" $ do + parseFailure day "Mon" + parseFailure day "Thu" + + describe "Rfc2822.obs_mbox_list" $ do + it "parses hand-picked inputs correctly" $ do + parseTest obs_mbox_list "," `shouldReturn` [] + parseTest obs_mbox_list "Joe Doe ,( \r\n bla),,jane@\r\n example.net \r\n (Jane Doe)," `shouldReturn` + [NameAddr (Just "Joe Doe") "joe@example.org",NameAddr Nothing "jane@example.net"] + + it "fails properly on incomplete input" $ + parseFailure obs_mbox_list "foo@example.org" + + describe "Rfc2822.subject" $ + it "doesn't consume leading whitespace" $ + parseTest subject "Subject: foo\r\n" `shouldReturn` " foo" + + describe "Rfc2822.comment" $ + it "doesn't consume leading whitespace" $ + parseTest comments "Comments: foo\r\n" `shouldReturn` " foo" + + -- Most of the following test cases have been adapted from + -- . + describe "Rfc2822.addr_spec" $ + it "parses hand-picked inputs correctly" $ do + parseFailure addr_spec "()[]\\;:,><@example.com" -- Disallowed Characters + parseFailure addr_spec " -- test --@example.com" -- No spaces allowed in local part + parseFailure addr_spec "-@..com" + parseFailure addr_spec "-@a..com" + parseFailure addr_spec ".@" + parseFailure addr_spec ".@example.com" -- Phil Haack says so + parseFailure addr_spec ".dot@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec ".first.last@example.com" -- Local part starts with a dot + parseFailure addr_spec ".test@example.com" + parseFailure addr_spec ".wooly@example.com" -- Phil Haack says so + parseFailure addr_spec "@@bar.com" + parseFailure addr_spec "@NotAnEmail" -- Phil Haack says so + parseFailure addr_spec "@bar.com" + parseFailure addr_spec "@example.com" -- No local part + parseFailure addr_spec "Abc\\@def@example.com" -- Was incorrectly given as a valid address in the original RFC3696 + parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ L\\.@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "Doug\\ \\\"Ace\\\"\\ Lovell@example.com" -- Escaping can only happen in a quoted string + parseFailure addr_spec "Fred\\ Bloggs@example.com" -- Was incorrectly given as a valid address in the original RFC3696 + parseFailure addr_spec "Ima Fool@example.com" -- Phil Haack says so + parseFailure addr_spec "Invalid \\\n Folding \\\n Whitespace@example.com" -- This isn't FWS so Dominic Sayers says it's invalid + parseFailure addr_spec "Joe.\\\\Blow@example.com" -- Was incorrectly given as a valid address in the original RFC3696 + parseFailure addr_spec "NotAnEmail" -- Phil Haack says so + parseFailure addr_spec "[test]@example.com" -- Square brackets only allowed within quotes + parseFailure addr_spec "\"Doug \"Ace\" L.\"@example.com" -- Doug Lovell says this should fail + parseIdemTest addr_spec "\"\"@example.com" + parseFailure addr_spec "\"\"\"@example.com" -- Local part contains unescaped excluded characters + parseFailure addr_spec "\"\\\"@example.com" -- Local part cannot end with a backslash + parseFailure addr_spec "\"first\"last\"@example.com" -- Local part contains unescaped excluded characters + parseFailure addr_spec "\"first\\\\\"last\"@example.com" -- Contains an unescaped quote + parseFailure addr_spec "\"foo\"(yay)@(hoopla)[1.2.3.4]" -- Address literal can't be commented (RFC5321) + parseFailure addr_spec "\"null \NUL\"@char.com" -- cannot have unescaped null character + parseFailure addr_spec "\"qu@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "\"test\"blah\"@example.com" -- Phil Haack says so + parseFailure addr_spec "\"test\"test\"@example.com" -- Quotes cannot be nested + parseFailure addr_spec "\"test\\\r\n blah\"@example.com" -- Folding white space can't appear within a quoted pair + parseFailure addr_spec "\"test\rblah\"@example.com" -- Quoted string specifically excludes carriage returns + parseFailure addr_spec "a(a(b(c)d(e(f))g)(h(i)j)@example.com" -- Braces are not properly matched + parseFailure addr_spec "a@bar.com." + parseFailure addr_spec "aaa.com" + parseFailure addr_spec "aaa@.123" + parseFailure addr_spec "aaa@.com" + parseFailure addr_spec "aaa@[123.123.123.123]a" -- extra data outside ip + parseFailure addr_spec "abc@def@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "abc\\@def@example.com" -- This example from RFC3696 was corrected in an erratum + parseFailure addr_spec "abc\\@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "abc\\\\@def@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "abc\\\\@example.com" -- This example from RFC3696 was corrected in an erratum + parseFailure addr_spec "cal(foo(bar)@iamcal.com" -- Unclosed parenthesis in comment + parseFailure addr_spec "cal(foo)bar)@iamcal.com" -- Too many closing parentheses + parseFailure addr_spec "cal(foo\\)@iamcal.com" -- Backslash at end of comment has nothing to escape + parseFailure addr_spec "dot.@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "doug@" -- Doug Lovell says this should fail + parseFailure addr_spec "first(12345678901234567890123456789012345678901234567890)last@(1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890)example.com" -- Too long with comments, not too long without + parseFailure addr_spec "first(abc(\"def\".ghi).mno)middle(abc(\"def\".ghi).mno).last@(abc(\"def\".ghi).mno)example(abc(\"def\".ghi).mno).(abc(\"def\".ghi).mno)com(abc(\"def\".ghi).mno)" -- Can't have comments or white space except at an element boundary + parseFailure addr_spec "first(middle)last@example.com" -- Can't have a comment or white space except at an element boundary + parseFailure addr_spec "first..last@example.com" -- Local part has consecutive dots + parseFailure addr_spec "first.last" -- No @ + parseFailure addr_spec "first.last.@example.com" -- Local part ends with a dot + parseFailure addr_spec "first.last@" -- No domain + parseFailure addr_spec "first\\@last@example.com" -- Escaping can only happen within a quoted string + parseFailure addr_spec "first\\\\@last@example.com" -- Local part contains unescaped excluded characters + parseFailure addr_spec "first\\last@example.com" -- Unquoted string must be an atom + parseFailure addr_spec "gatsby@f.sc.ot.t.f.i.tzg.era.l.d." -- Doug Lovell says this should fail + parseFailure addr_spec "hello world@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "ote\"@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "phil.h\\@\\@ck@haacked.com" -- Escaping can only happen in a quoted string + parseFailure addr_spec "pootietang.@example.com" -- Phil Haack says so + parseFailure addr_spec "test..test@example.com" + parseFailure addr_spec "test.@example.com" + parseFailure addr_spec "test.\r\n\r\n obs@syntax.com" -- obs-fws must have at least one WSP per line + parseFailure addr_spec "test.example.com" + parseFailure addr_spec "test@." -- Dave Child says so + parseFailure addr_spec "test@...........com" -- ...... + parseFailure addr_spec "test@.org" -- Dave Child says so + parseFailure addr_spec "test@123.123.123.123]" -- Dave Child says so + parseFailure addr_spec "test@@example.com" + parseFailure addr_spec "test@[123.123.123.123" -- Dave Child says so + parseFailure addr_spec "test@example." -- Dave Child says so + parseFailure addr_spec "test@test@example.com" + parseFailure addr_spec "two..dot@example.com" -- Doug Lovell says this should fail + parseFailure addr_spec "wo..oly@example.com" -- Phil Haack says so + parseFailure addr_spec "{^c\\@**Dog^}@cartoon.com" -- This is a throwaway example from Doug Lovell's article. Actually it's not a valid address. + parseTest addr_spec " \r\n (\r\n x \r\n ) \r\n first\r\n ( \r\n x\r\n ) \r\n .\r\n ( \r\n x) \r\n last \r\n ( x \r\n ) \r\n @example.com" `shouldReturn` "first.last@example.com" + parseIdemTest addr_spec "!def!xyz%abc@example.com" + parseIdemTest addr_spec "$A12345@example.com" + parseTest addr_spec "(foo)cal(bar)@(baz)iamcal.com(quux)" `shouldReturn` "cal@iamcal.com" + parseIdemTest addr_spec "+1~1+@example.com" + parseIdemTest addr_spec "+@b.c" -- TLDs can be any length + parseIdemTest addr_spec "+@b.com" + parseTest addr_spec "1234 @ local(blah) .machine .example" `shouldReturn` "1234@local.machine.example" + parseIdemTest addr_spec "1234567890123456789012345678901234567890123456789012345678901234@example.com" + parseIdemTest addr_spec "123456789012345678901234567890123456789012345678901234567890@12345678901234567890123456789012345678901234567890123456789.12345678901234567890123456789012345678901234567890123456789.123456789012345678901234567890123456789012345678901234567890123.example.com" + parseIdemTest addr_spec "1234567890@example.com" + parseTest addr_spec "HM2Kinsists@(that comments are allowed)this.is.ok" `shouldReturn` "HM2Kinsists@this.is.ok" + parseIdemTest addr_spec "Ima.Fool@example.com" + parseIdemTest addr_spec "TEST@example.com" + parseTest addr_spec "Test.\r\n Folding.\r\n Whitespace@example.com" `shouldReturn` "Test.Folding.Whitespace@example.com" + parseIdemTest addr_spec "\"Abc@def\"@example.com" + parseIdemTest addr_spec "\"Abc\\@def\"@example.com" + parseIdemTest addr_spec "\"Austin@Powers\"@example.com" + parseIdemTest addr_spec "\"Doug \\\"Ace\\\" L.\"@example.com" + parseIdemTest addr_spec "\"Fred Bloggs\"@example.com" + parseIdemTest addr_spec "\"Fred\\ Bloggs\"@example.com" + parseIdemTest addr_spec "\"Ima Fool\"@example.com" + parseIdemTest addr_spec "\"Ima.Fool\"@example.com" + parseIdemTest addr_spec "\"Joe.\\\\Blow\"@example.com" + parseIdemTest addr_spec "\"Joe\\\\Blow\"@example.com" + parseIdemTest addr_spec "\"Test \\\"Fail\\\" Ing\"@example.com" + parseIdemTest addr_spec "\"[[ test ]]\"@example.com" + parseIdemTest addr_spec "\"first last\"@example.com" + parseIdemTest addr_spec "\"first(last)\"@example.com" + parseIdemTest addr_spec "\"first..last\"@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "\"first.middle.last\"@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "\"first.middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "\"first@last\"@example.com" + parseIdemTest addr_spec "\"first\".\"last\"@example.com" + parseIdemTest addr_spec "\"first\".\"middle\".\"last\"@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "\"first\".last@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "\"first\".middle.\"last\"@example.com" + parseIdemTest addr_spec "\"first\\\"last\"@example.com" + parseIdemTest addr_spec "\"first\\\\\\\"last\"@example.com" + parseIdemTest addr_spec "\"first\\\\last\"@example.com" + parseIdemTest addr_spec "\"first\\last\"@example.com" -- Any character can be escaped in a quoted string + parseIdemTest addr_spec "\"hello my name is\"@stutter.com" + parseIdemTest addr_spec "\"null \\\NUL\"@char.com" -- can have escaped null character + parseIdemTest addr_spec "\"test.test\"@example.com" + parseIdemTest addr_spec "\"test@test\"@example.com" + parseIdemTest addr_spec "\"test\\\"blah\"@example.com" + parseIdemTest addr_spec "\"test\\\\blah\"@example.com" + parseIdemTest addr_spec "\"test\\\rblah\"@example.com" -- Quoted string specifically excludes carriage returns unless escaped + parseIdemTest addr_spec "\"test\\blah\"@example.com" -- Any character can be escaped in a quoted string + parseIdemTest addr_spec "\"test\\test\"@example.com" -- Any character can be escaped in a quoted string + parseIdemTest addr_spec "\"test\r\n blah\"@example.com" -- This is a valid quoted string with folding white space + parseIdemTest addr_spec "_Yosemite.Sam@example.com" + parseIdemTest addr_spec "_somename@example.com" + parseTest addr_spec "a(a(b(c)d(e(f))g)h(i)j)@example.com" `shouldReturn` "a@example.com" + parseIdemTest addr_spec "a-b@bar.com" + parseIdemTest addr_spec "a@b.co-foo.uk" + parseIdemTest addr_spec "a@bar.com" + parseIdemTest addr_spec "aaa@[123.123.123.123]" + parseTest addr_spec "c@(Chris's host.)public.example" `shouldReturn` "c@public.example" + parseTest addr_spec "cal(foo\\)bar)@iamcal.com" `shouldReturn` "cal@iamcal.com" + parseTest addr_spec "cal(foo\\@bar)@iamcal.com" `shouldReturn` "cal@iamcal.com" + parseTest addr_spec "cal(woo(yay)hoopla)@iamcal.com" `shouldReturn` "cal@iamcal.com" + parseTest addr_spec "cal@iamcal(woo).(yay)com" `shouldReturn` "cal@iamcal.com" + parseIdemTest addr_spec "customer/department=shipping@example.com" + parseIdemTest addr_spec "customer/department@example.com" + parseIdemTest addr_spec "dclo@us.ibm.com" + parseTest addr_spec "first().last@example.com" `shouldReturn` "first.last@example.com" + parseTest addr_spec "first(Welcome to\r\n the (\"wonderful\" (!)) world\r\n of email)@example.com" `shouldReturn` "first@example.com" + parseTest addr_spec "first(a\"bc.def).last@example.com" `shouldReturn` "first.last@example.com" + parseTest addr_spec "first(abc.def).last@example.com" `shouldReturn` "first.last@example.com" + parseTest addr_spec "first(abc\\(def)@example.com" `shouldReturn` "first@example.com" + parseTest addr_spec "first.(\")middle.last(\")@example.com" `shouldReturn` "first.middle.last@example.com" + parseTest addr_spec "first.(\r\n middle\r\n )last@example.com" `shouldReturn` "first.last@example.com" + parseIdemTest addr_spec "first.\"last\"@example.com" -- obs-local-part form as described in RFC 2822 + parseIdemTest addr_spec "first.\"mid\\dle\".\"last\"@example.com" -- Backslash can escape anything but must escape something + parseIdemTest addr_spec "first.last@123.example.com" + parseIdemTest addr_spec "first.last@1xample.com" + parseIdemTest addr_spec "first.last@[12.34.56.78]" + parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:12.34.56.78]" + parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666:7777:8888]" + parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333:4444:5555:6666::]" + parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:12.34.56.78]" + parseIdemTest addr_spec "first.last@[IPv6:1111:2222:3333::4444:5555:6666]" + parseIdemTest addr_spec "first.last@[IPv6:::1111:2222:3333:4444:5555:6666]" + parseIdemTest addr_spec "first.last@[IPv6:::12.34.56.78]" + parseIdemTest addr_spec "first.last@example.com" + parseTest addr_spec "first.last@x(1234567890123456789012345678901234567890123456789012345678901234567890).com" `shouldReturn` "first.last@x.com" + parseIdemTest addr_spec "first.last@x23456789012345678901234567890123456789012345678901234567890123.example.com" + parseTest addr_spec "jdoe@machine(comment). example" `shouldReturn` "jdoe@machine.example" + parseIdemTest addr_spec "name.lastname@domain.com" + parseTest addr_spec "pete(his account)@silly.test(his host)" `shouldReturn` "pete@silly.test" + parseIdemTest addr_spec "peter.piper@example.com" + parseIdemTest addr_spec "shaitan@my-domain.thisisminekthx" -- Disagree with Paul Gregg here + parseIdemTest addr_spec "t*est@example.com" + parseIdemTest addr_spec "test+test@example.com" + parseIdemTest addr_spec "test-test@example.com" + parseTest addr_spec "test. \r\n \r\n obs@syntax.com" `shouldReturn` "test.obs@syntax.com" + parseTest addr_spec "test.\"test\"@example.com" `shouldReturn` "test.\"test\"@example.com" + parseTest addr_spec "test.\r\n \r\n obs@syntax.com" `shouldReturn` "test.obs@syntax.com" + parseIdemTest addr_spec "test.test@example.com" + parseIdemTest addr_spec "test@123.123.123.x123" + parseIdemTest addr_spec "test@[123.123.123.123]" + parseIdemTest addr_spec "test@example.com" + parseIdemTest addr_spec "test@example.example.com" + parseIdemTest addr_spec "test@example.example.example.com" + parseIdemTest addr_spec "user%uucp!path@somehost.edu" + parseIdemTest addr_spec "user+mailbox@example.com" + parseIdemTest addr_spec "valid@special.museum" + parseIdemTest addr_spec "x@x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x23456789.x234" + parseIdemTest addr_spec "{_test_}@example.com" + parseIdemTest addr_spec "~@example.com" + + describe "Rfc2822.path" $ do + it "parses hand-picked inputs correctly" $ + parseTest path " " `shouldReturn` "" + it "loses the route-part of an obsolete routing address" $ + parseTest path "<@example1.org,@example2.org:joe@example.org>" `shouldReturn` "" + + describe "Rfc2822.dot_atom" $ do + it "consumes leading and trailing whitespace" $ + parseTest dot_atom " first.last " `shouldReturn` "first.last" + it "does not allow interspersed whitespace" $ do + parseFailure dot_atom "first . last" + parseFailure dot_atom "first .last" + parseFailure dot_atom "first. last" + + describe "Rfc2822.local_part" $ do + it "consumes leading and trailing whitespace" $ + parseTest local_part " first.last " `shouldReturn` "first.last" + it "consumes interspersed whitespace (obsolete syntax)" $ do + parseTest local_part " first . last " `shouldReturn` "first.last" + parseTest local_part " first .last " `shouldReturn` "first.last" + parseTest local_part " first. last " `shouldReturn` "first.last" + + describe "Rfc2822.return_path" $ do + it "parses hand-picked inputs correctly" $ do + parseTest return_path "Return-Path: \r\n" `shouldReturn` "" + parseTest return_path "Return-Path: <>\r\n" `shouldReturn` "<>" + it "loses the route-part of an obsolete routing address" $ + parseTest return_path "Return-Path: <@example1.org,@example2.org:joe@example.org>\r\n" `shouldReturn` "" + + describe "Rfc2822.word" $ + it "parses hand-picked inputs correctly" $ + parseTest word " foobar " `shouldReturn` "foobar" + + describe "Rfc2822.body" $ + it "parses 8-bit characters correctly" $ + parseIdemTest body "abc äöüß def"