hsemail 2 → 2.1.0
raw patch · 8 files changed
+397/−484 lines, 8 filesdep +timedep −doctestdep −old-timedep ~basedep ~parsec
Dependencies added: time
Dependencies removed: doctest, old-time
Dependency ranges changed: base, parsec
Files
- ChangeLog.md +63/−0
- README.md +7/−0
- hsemail.cabal +32/−63
- src/Text/Parsec/Rfc2234.hs +6/−5
- src/Text/Parsec/Rfc2821.hs +66/−190
- src/Text/Parsec/Rfc2822.hs +214/−213
- test/doctest.hs +0/−6
- test/spec.hs +9/−7
+ ChangeLog.md view
@@ -0,0 +1,63 @@+# Change Log for hsemail++## v2.1.0++* Re-write code to use the modern `time` library rather than `old-time`.+* rfc2821: drop the entire smtp FSM stuff+* hsemail.cabal: drop unnecessary build-depends+* Drop support for GHC versions prior to 7.10.x.++## v2++* Import Data.Monoid to fix build with GHC 7.8.x.+* Ensure that `body` consumes remaining input.+* Refrain from parsing body.++## v1.7.7++* rfc2822: allow 8 bit characters is message bodys++## v1.7.6++* move the project to github++## v1.7.5++* rfc2822: support obsolete local_part syntax+* rfc2822: support obsolete domain syntax+* rfc2822: fixed typo in the parser for domain literals+* rfc2822: support obsolete quoted-pair syntax+* Greatly extend the test suite.++## v1.7.4++* rfc2822: fix `return_path` parser+* rfc2822: improve documentation (especially `subject`, `comments`)++## v1.7.3++* rfc2822: fix infinite recursion between `day` and `obs_day`++## v1.7.2++* `word` parser failed for quoted string prefixed by ws++## v1.7.1++* Updated Gero's e-mail address.++## v1.7++* Fixed plenty of GHC and HLint warnings.++## v1.6++* rfc2822: derive `Show` for new `GenericMessage` type++## v1.5++* `Message` is now usable with `ByteString` or other types as body.++## 1.4++* Initial version.
+ README.md view
@@ -0,0 +1,7 @@+hsemail+=======++[](http://hackage.haskell.org/package/hsemail)+[](http://stackage.org/lts/package/hsemail)+[](http://stackage.org/nightly/package/hsemail)+[](https://travis-ci.org/peti/hsemail)
hsemail.cabal view
@@ -1,72 +1,41 @@--- This file has been generated from package.yaml by hpack version 0.17.0.------ see: https://github.com/sol/hpack--name: hsemail-version: 2-synopsis: Parsec parsers for the RFC2822 Internet Message format-description: Parsec parsers for the Internet Message format defined in RFC 2821 and 2822.-category: Parsing-stability: stable-homepage: https://github.com/peti/hsemail#readme-bug-reports: https://github.com/peti/hsemail/issues-author: Peter Simons,- Ali Abrar,- Gero Kriependorf,- Marty Pauley-maintainer: Peter Simons <simons@cryp.to>-license: BSD3-license-file: LICENSE-tested-with: GHC > 7.8 && < 8.1-build-type: Simple-cabal-version: >= 1.10+name: hsemail+version: 2.1.0+synopsis: Parsec parsers for the RFC2822 Internet Message format+description: Parsec parsers for the Internet Message format defined in RFC 2821 and+ 2822.+license: BSD3+license-file: LICENSE+author: Peter Simons,+ Ali Abrar,+ Gero Kriependorf,+ Marty Pauley+maintainer: Peter Simons <simons@cryp.to>+stability: stable+tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5+category: Parsing+homepage: https://github.com/peti/hsemail#readme+bug-reports: https://github.com/peti/hsemail/issues+build-type: Simple+extra-source-files: ChangeLog.md+ README.md+cabal-version: >= 1.10 source-repository head- type: git+ type: git location: https://github.com/peti/hsemail 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 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+ exposed-modules: Text.Parsec.Rfc2234+ Text.Parsec.Rfc2821+ Text.Parsec.Rfc2822+ other-modules: Paths_hsemail+ hs-source-dirs: src+ build-depends: base > 4.8 && < 5, mtl, parsec >= 3.1, time default-language: Haskell2010 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+ type: exitcode-stdio-1.0+ main-is: spec.hs+ hs-source-dirs: test+ build-depends: base, hsemail, hspec, parsec, time default-language: Haskell2010
src/Text/Parsec/Rfc2234.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Parsec.Rfc2234- Copyright : (c) 2013 Peter Simons+ Copyright : (c) 2007-2019 Peter Simons License : BSD3 Maintainer : simons@cryp.to@@ -15,6 +14,8 @@ here to avoid conflicts with Parsec's 'char' function. -} +{-# LANGUAGE FlexibleContexts #-}+ module Text.Parsec.Rfc2234 where import Control.Monad ( liftM2, replicateM )@@ -36,8 +37,8 @@ -- |Case-insensitive variant of Parsec's 'string' function. -caseString :: Stream s m Char => String -> ParsecT s u m ()-caseString cs = mapM_ caseChar cs <?> cs+caseString :: Stream s m Char => String -> ParsecT s u m String+caseString cs = mapM caseChar cs <?> cs -- |Match a parser at least @n@ times. @@ -54,7 +55,7 @@ | n < 0 = return [] | n > m = return [] | n == m = replicateM n p- | n == 0 = foldr (<|>) (return []) (map (\x -> try $ replicateM x p) (reverse [1..m]))+ | n == 0 = foldr ((<|>) . (\x -> try (replicateM x p))) (return []) (reverse [1..m]) | otherwise = liftM2 (++) (replicateM n p) (manyNtoM 0 (m-n) p) -- |Helper function to generate 'Parser'-based instances for
src/Text/Parsec/Rfc2821.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Parsec.Rfc2821- Copyright : (c) 2013 Peter Simons+ Copyright : (c) 2007-2019 Peter Simons License : BSD3 Maintainer : simons@cryp.to Stability : provisional Portability : portable - This module exports parser combinators for the grammar- described in RFC2821, \"Simple Mail Transfer Protocol\",- <http://www.faqs.org/rfcs/rfc2821.html>.--}+ This module exports parser combinators for the grammar described in RFC2821,+ \"Simple Mail Transfer Protocol\", <http://www.faqs.org/rfcs/rfc2821.html>.+ -} +{-# LANGUAGE FlexibleContexts #-}+ module Text.Parsec.Rfc2821 where import Text.Parsec.Rfc2234@@ -27,117 +27,13 @@ {-# 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+-- * Data Types for ESMTP Commands ---------------------------------------------------------------------- --- |The 'smtpCmd' parser will create this data type from a--- string. Note that /all/ command parsers expect their--- input to be terminated with 'crlf'.+-- | 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+data EsmtpCmd = Helo String | Ehlo String | MailFrom Mailbox -- ^ Might be 'nullPath'.@@ -160,7 +56,7 @@ -- command (in all upper-case) and the 'ParseError' -- is, obviously, the error description. -instance Show SmtpCmd where+instance Show EsmtpCmd where show (Helo str) = "HELO " ++ str show (Ehlo str) = "EHLO " ++ str show (MailFrom mbox) = "MAIL FROM:" ++ show mbox@@ -180,11 +76,11 @@ | 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.+-- | 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 @@ -205,27 +101,26 @@ readsPrec _ = parsec2read (path <|> mailbox) readList = error "reading [Mailbox] is not supported" --- |@nullPath@ @=@ @'Mailbox' [] \"\" \"\" = \"\<\>\"@+-- | @nullPath@ @=@ @'Mailbox' [] \"\" \"\" = \"\<\>\"@ nullPath :: Mailbox nullPath = Mailbox [] [] [] --- |@postmaster@ @=@ @'Mailbox' [] \"postmaster\" \"\" = \"\<postmaster\>\"@+-- | @postmaster@ @=@ @'Mailbox' [] \"postmaster\" \"\" = \"\<postmaster\>\"@ postmaster :: Mailbox postmaster = Mailbox [] "postmaster" [] ------------------------------------------------------------------------- * Data Types for SMTP Replies+-- * Data Types for ESMTP 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:+-- | An ESMTP reply is a three-digit return code plus some waste of bandwidth+-- called \"comments\". This is what the list of strings is for; one string per+-- line in the reply. 'show' will append an \"@\\r\\n@\" end-of-line marker to+-- each entry in that list, so that the resulting string is ready to be sent+-- back to the peer. For example: -- -- >>> show $ Reply (Code Success MailSystem 0) ["worked", "like", "a charm" ] -- "250-worked\r\n250-like\r\n250 a charm\r\n"@@ -235,9 +130,9 @@ -- >>> show $ Reply (Code Success MailSystem 0) [] -- "250 Success in category MailSystem\r\n" -data SmtpReply = Reply SmtpCode [String]+data EsmtpReply = Reply EsmtpCode [String] -data SmtpCode = Code SuccessCode Category Int+data EsmtpCode = Code SuccessCode Category Int data SuccessCode = Unused0@@ -257,7 +152,7 @@ | MailSystem deriving (Enum, Bounded, Eq, Ord, Show) -instance Show SmtpReply where+instance Show EsmtpReply where show (Reply c@(Code suc cat _) []) = let msg = show suc ++ " in category " ++ show cat in@@ -274,42 +169,40 @@ in concat msg' -instance Show SmtpCode where+instance Show EsmtpCode where show (Code suc cat n) = assert (n >= 0 && n <= 9) $ (show . fromEnum) suc ++ (show . fromEnum) cat ++ show n --- |Construct a 'Reply'. Fails 'assert' if invalid numbers--- are given.+-- | Construct a 'Reply'. Fails 'assert' if invalid numbers are given. -reply :: Int -> Int -> Int -> [String] -> SmtpReply+reply :: Int -> Int -> Int -> [String] -> EsmtpReply reply suc c n msg = assert (suc >= 0 && suc <= 5) $ assert (c >= 0 && c <= 5) $ assert (n >= 0 && n <= 9) $ Reply (Code (toEnum suc) (toEnum c) n) msg --- |A reply constitutes \"success\" if the status code is--- any of 'PreliminarySuccess', 'Success', or--- 'IntermediateSuccess'.+-- | A reply constitutes \"success\" if the status code is any of+-- 'PreliminarySuccess', 'Success', or 'IntermediateSuccess'. -isSuccess :: SmtpReply -> Bool+isSuccess :: EsmtpReply -> Bool isSuccess (Reply (Code PreliminarySuccess _ _) _) = True isSuccess (Reply (Code Success _ _) _) = True isSuccess (Reply (Code IntermediateSuccess _ _) _) = True isSuccess _ = False --- |A reply constitutes \"failure\" if the status code is--- either 'PermanentFailure' or 'TransientFailure'.+-- | A reply constitutes \"failure\" if the status code is either+-- 'PermanentFailure' or 'TransientFailure'. -isFailure :: SmtpReply -> Bool+isFailure :: EsmtpReply -> Bool isFailure (Reply (Code PermanentFailure _ _) _) = True isFailure (Reply (Code TransientFailure _ _) _) = True isFailure _ = False --- |The replies @221@ and @421@ signify 'Shutdown'.+-- | The replies @221@ and @421@ signify 'Shutdown'. -isShutdown :: SmtpReply -> Bool+isShutdown :: EsmtpReply -> Bool isShutdown (Reply (Code Success Connection 1) _) = True isShutdown (Reply (Code TransientFailure Connection 1) _) = True isShutdown _ = False@@ -318,31 +211,25 @@ -- * 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 ESMTP commands defined below. Note that+-- /all/ command parsers expect their input to be terminated with 'crlf'. --- |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 EsmtpCmd -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+-- | The parser name \"data\" was taken.+smtpData :: Stream s m Char => ParsecT s u m EsmtpCmd+rset, quit, turn, helo, ehlo, mail :: Stream s m Char => ParsecT s u m EsmtpCmd+rcpt, send, soml, saml, vrfy, expn :: Stream s m Char => ParsecT s u m EsmtpCmd+help :: Stream s m Char => ParsecT s u m EsmtpCmd --- |May have an optional 'word' argument, but it is ignored.-noop :: Stream s m Char => ParsecT s u m SmtpCmd+-- | May have an optional 'word' argument, but it is ignored.+noop :: Stream s m Char => ParsecT s u m EsmtpCmd smtpData = mkCmd0 "DATA" Data rset = mkCmd0 "RSET" Rset@@ -390,13 +277,7 @@ 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)+mailbox = (Mailbox [] <$> local_part <* char '@' <*> domain) <?> "mailbox" local_part :: Stream s m Char => ParsecT s u m String local_part = (dot_string <|> quoted_string) <?> "local-part"@@ -413,7 +294,7 @@ at_domain :: Stream s m Char => ParsecT s u m String at_domain = (char '@' >> domain) <?> "at-domain" --- |/TODO/: Add IPv6 address and general literals+-- | /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" @@ -459,8 +340,8 @@ 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'.+-- | 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)@@ -471,21 +352,19 @@ -- * 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.+-- | Make the string 'crlf' terminated no matter what. \'@\\n@\' is expanded,+-- otherwise 'crlf' is appended. Note that if the string was terminated+-- incorrectly before, it still is. This function is useful when reading input+-- with 'System.IO.hGetLine' which removes the end-of-line delimiter. +{-# ANN fixCRLF "HLint: ignore Use list literal pattern" #-} fixCRLF :: String -> String fixCRLF ('\r' :'\n':[]) = fixCRLF [] fixCRLF ( x :'\n':[]) = x : fixCRLF [] fixCRLF ( x : xs ) = x : fixCRLF xs fixCRLF [ ] = "\r\n" --- |Construct a parser for a command without arguments.--- Expects 'crlf'!+-- | 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@@ -493,13 +372,12 @@ _ <- 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'!+-- | 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 :: Stream s m Char => String -> (a -> EsmtpCmd) -> ParsecT s u m a+ -> ParsecT s u m EsmtpCmd mkCmd1 str cons p = do try (caseString str) _ <- wsp@@ -512,10 +390,8 @@ 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 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 :: 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))
src/Text/Parsec/Rfc2822.hs view
@@ -1,29 +1,31 @@-{-# LANGUAGE FlexibleContexts #-} {- | Module : Text.Parsec.Rfc2822- Copyright : (c) 2013 Peter Simons+ Copyright : (c) 2007-2019 Peter Simons License : BSD3 Maintainer : simons@cryp.to Stability : provisional Portability : portable - This module provides parsers for the grammar defined in- RFC2822, \"Internet Message Format\",- <http://www.faqs.org/rfcs/rfc2822.html>.+ This module provides parsers for the grammar defined in RFC2822,+ \"Internet Message Format\", <http://www.faqs.org/rfcs/rfc2822.html>. -} +{-# LANGUAGE FlexibleContexts #-}+ module Text.Parsec.Rfc2822 where import Text.Parsec.Rfc2234 hiding ( quoted_pair, quoted_string ) -import Control.Monad ( replicateM )+import Control.Monad ( replicateM, guard ) import Data.Char ( ord )+import Data.Functor import Data.List ( intercalate ) import Data.Maybe ( catMaybes ) import Data.Monoid ( Monoid, mempty )-import System.Time-import Text.Parsec hiding (crlf)+import Data.Time.Calendar+import Data.Time.LocalTime+import Text.Parsec hiding ( crlf ) -- Customize hlint ... {-# ANN module "HLint: ignore Use camelCase" #-}@@ -143,13 +145,13 @@ atext = alpha <|> digit <|> oneOf "!#$%&'*+-/=?^_`{|}~" <?> "US-ASCII character (excluding controls, space, and specials)" --- |Match one or more 'atext' characters and skip any preceeding or+-- |Match one or more 'atext' characters and skip any preceding or -- trailing 'cfws'. atom :: Stream s m Char => ParsecT s u m String atom = unfold (many1 atext <?> "atom") --- |Match 'dot_atom_text' and skip any preceeding or trailing 'cfws'.+-- |Match 'dot_atom_text' and skip any preceding or trailing 'cfws'. dot_atom :: Stream s m Char => ParsecT s u m String dot_atom = unfold (dot_atom_text <?> "dot atom")@@ -177,7 +179,7 @@ <?> "quoted string content" -- |Match any number of 'qcontent' between double quotes. Any 'cfws'--- preceeding or following the \"atom\" is skipped automatically.+-- preceding or following the \"atom\" is skipped automatically. quoted_string :: Stream s m Char => ParsecT s u m String quoted_string = unfold (do _ <- dquote@@ -231,179 +233,180 @@ -- > 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+-- returns an appropriate 'ZonedTime' ----- as a perfectly valid date.+-- TODO: Nor will the 'date_time' parser perform /any/ consistency checking. It+-- will accept ----- 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.)+-- >>> parseTest date_time "Wed, 30 Apr 2002 13:12 +0100"+-- 2002-04-30 13:12:00 +0100 -date_time :: Stream s m Char => ParsecT s u m CalendarTime-date_time = do wd <- option Monday (try (do wd <- day_of_week- _ <- char ','- return wd))- (y,m,d) <- date+date_time :: Stream s m Char => ParsecT s u m ZonedTime+date_time = do optional (try (day_of_week >> char ','))+ day <- date _ <- fws (td,z) <- time optional cfws- return (CalendarTime y m d (tdHour td) (tdMin td) (tdSec td) 0 wd 0 "" z False)+ return (ZonedTime (LocalTime day td) z) <?> "date/time specification" -- |This parser matches a 'day_name' or an 'obs_day_of_week' (optionally -- wrapped in folding whitespace) and return its 'Day' value. -day_of_week :: Stream s m Char => ParsecT s u m Day+day_of_week :: Stream s m Char => ParsecT s u m String day_of_week = try (between (optional fws) (optional fws) day_name <?> "name of a day-of-the-week") <|> obs_day_of_week -- |This parser will the abbreviated weekday names (\"@Mon@\", \"@Tue@\", ...) -- and return the appropriate 'Day' value. -day_name :: Stream s m Char => ParsecT s u m 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 }+day_name :: Stream s m Char => ParsecT s u m String+day_name = caseString "Mon"+ <|> try (caseString "Tue")+ <|> caseString "Wed"+ <|> caseString "Thu"+ <|> caseString "Fri"+ <|> try (caseString "Sat")+ <|> caseString "Sun" <?> "name of a day-of-the-week" -- |This parser will match a date of the form \"@dd:mm:yyyy@\" and return -- a tripple of the form (Int,Month,Int) - corresponding to -- (year,month,day). -date :: Stream s m Char => ParsecT s u m (Int, Month, Int)-date = do d <- day- m <- month- y <- year- return (y,m,d)- <?> "date specification"+date :: Stream s m Char => ParsecT s u m Day+date = do d <- day+ m <- month+ y <- year+ return (fromGregorian (fromIntegral y) m d)+ <?> "date specification" -- |This parser will match a four digit number and return its integer -- value. No range checking is performed. -year :: Stream s m Char => ParsecT s u m Int-year = do y <- manyN 4 digit- return (read y :: Int)- <?> "year"+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+month :: Stream s m Char => ParsecT s u m Int+month = try (between (optional fws) (optional fws) month_name <?> "month name")+ <|> obs_month -- |This parser will the abbreviated month names (\"@Jan@\", \"@Feb@\", ...)--- and return the appropriate 'Month' value.+-- and return the appropriate 'Int' value in the range of (1,12). -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"+month_name :: Stream s m Char => ParsecT s u m Int+month_name = (try (caseString "Jan") $> 1)+ <|> (caseString "Feb" $> 2)+ <|> (try (caseString "Mar") $> 3)+ <|> (try (caseString "Apr") $> 4)+ <|> (caseString "May" $> 5)+ <|> (try (caseString "Jun") $> 6)+ <|> (caseString "Jul" $> 7)+ <|> (caseString "Aug" $> 8)+ <|> (caseString "Sep" $> 9)+ <|> (caseString "Oct" $> 10)+ <|> (caseString "Nov" $> 11)+ <|> (caseString "Dec" $> 12)+ <?> "month name" -- Internal helper function: match a 1 or 2-digit number (day of month). -day_of_month :: Stream s m Char => ParsecT s u m Int-day_of_month = fmap read (manyNtoM 1 2 digit)+day_of_month :: Stream s m Char => ParsecT s u m Int+day_of_month = do r <- fmap read (manyNtoM 1 2 digit)+ guard (r >= 1 && r < 31)+ return r -- |Match a 1 or 2-digit number (day of month), recognizing both -- standard and obsolete folding syntax. -day :: Stream s m Char => ParsecT s u m Int-day = try obs_day <|> day_of_month <?> "day"+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+-- 'zone'. It returns the tuple (TimeOfDay,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"+time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone)+time = do t <- time_of_day+ _ <- fws+ z <- zone+ return (t,z)+ <?> "time and zone specification" -- |This parser will match a time-of-day specification of \"@hh:mm@\" or--- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeDiff'.+-- \"@hh:mm:ss@\" and return the corrsponding time as a 'TimeOfDay'.+--+-- >>> parseTest (time_of_day <* eof) "12:03:23"+-- 12:03:23+-- >>> parseTest (time_of_day <* eof) "99:99:99"+-- parse error at (line 1, column 3):unknown parse error -time_of_day :: Stream s m Char => ParsecT s u m 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"+time_of_day :: Stream s m Char => ParsecT s u m TimeOfDay+time_of_day = do h <- hour+ _ <- char ':'+ m <- minute+ s <- option 0 (do { _ <- char ':'; second } )+ return (TimeOfDay h m (fromIntegral s))+ <?> "time specification" --- |This parser will match a two-digit number and return its integer--- value. No range checking is performed.+-- |This parser matches a two-digit number in the range (0,24) and returns its+-- integer value.+--+-- >>> parseTest hour "034"+-- 3+-- >>> parseTest hour "99"+-- parse error at (line 1, column 3):unknown parse error -hour :: Stream s m Char => ParsecT s u m Int-hour = do r <- replicateM 2 digit- return (read r :: Int)- <?> "hour"+hour :: Stream s m Char => ParsecT s u m Int+hour = do r <- fmap read (replicateM 2 digit)+ guard (r >= 0 && r <= 24)+ return r+ <?> "hour" --- |This parser will match a two-digit number and return its integer--- value. No range checking is performed.+-- |This parser will match a two-digit number in the range (0,60) and return+-- its integer value.+--+-- >>> parseTest minute "34"+-- 34+-- >>> parseTest minute "61"+-- parse error at (line 1, column 3):unknown parse error+-- >>> parseTest (minute <* eof) "034"+-- parse error at (line 1, column 3):+-- unexpected '4'+-- expecting end of input -minute :: Stream s m Char => ParsecT s u m Int-minute = do r <- replicateM 2 digit- return (read r :: Int)- <?> "minute"+minute :: Stream s m Char => ParsecT s u m Int+minute = do r <- fmap read (replicateM 2 digit)+ guard (r >= 0 && r <= 60)+ return r+ <?> "minute" --- |This parser will match a two-digit number and return its integer--- value. No range checking takes place.+-- |This parser will match a two-digit number in the range (0,60) and return+-- its integer value.+--+-- >>> parseTest second "34"+-- 34 -second :: Stream s m Char => ParsecT s u m Int-second = do r <- replicateM 2 digit- return (read r :: Int)- <?> "second"+second :: Stream s m Char => ParsecT s u m Int+second = minute <?> "second" -- |This parser will match a timezone specification of the form -- \"@+hhmm@\" or \"@-hhmm@\" and return the zone's offset to UTC in -- seconds as an integer. 'obs_zone' is matched as well. -zone :: Stream s m Char => ParsecT s u m 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-+zone :: Stream s m Char => ParsecT s u m TimeZone+zone = do sign <- choice [char '+' $> 1, char '-' $> (-1) ]+ h <- hour+ m <- minute+ return (minutesToTimeZone (sign*((h*60)+m)))+ <|> obs_zone -- * Address Specification (section 3.4) @@ -433,11 +436,9 @@ -- 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"+name_addr = (NameAddr <$> maybeOption display_name <*> angle_addr) <?> "name address" + -- |Parse an 'angle_addr' or an 'obs_angle_addr' and return the address. angle_addr :: Stream s m Char => ParsecT s u m String@@ -542,7 +543,7 @@ -- * Overall message syntax (section 3.5) --- |This data type repesents a parsed Internet Message as defined in+-- |This data type represents a parsed Internet Message as defined in -- this RFC. It consists of an arbitrary number of header lines, -- represented in the 'Field' data type, and a message body, which may -- be empty.@@ -597,8 +598,8 @@ | Subject String | Comments String | Keywords [[String]]- | Date CalendarTime- | ResentDate CalendarTime+ | Date ZonedTime+ | ResentDate ZonedTime | ResentFrom [NameAddr] | ResentSender NameAddr | ResentTo [NameAddr]@@ -606,7 +607,7 @@ | ResentBcc [NameAddr] | ResentMessageID String | ResentReplyTo [NameAddr]- | Received ([(String,String)], CalendarTime)+ | Received ([(String,String)], ZonedTime) | ObsReceived [(String,String)] deriving (Show) @@ -623,39 +624,38 @@ -- 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) })- )-+fields = many $ choice+ [ try (From <$> from)+ , try (Sender <$> sender)+ , try (ReturnPath <$> return_path)+ , try (ReplyTo <$> reply_to)+ , try (To <$> to)+ , try (Cc <$> cc)+ , try (Bcc <$> bcc)+ , try (MessageID <$> message_id)+ , try (InReplyTo <$> in_reply_to)+ , try (References <$> references)+ , try (Subject <$> subject)+ , try (Comments <$> comments)+ , try (Keywords <$> keywords)+ , try (Date <$> orig_date)+ , try (ResentDate <$> resent_date)+ , try (ResentFrom <$> resent_from)+ , try (ResentSender <$> resent_sender)+ , try (ResentTo <$> resent_to)+ , try (ResentCc <$> resent_cc)+ , try (ResentBcc <$> resent_bcc)+ , try (ResentMessageID <$> resent_msg_id)+ , try (Received <$> received)+ , uncurry OptionalField <$> optional_field -- catch all+ ] -- ** The origination date field (section 3.6.1) -- |Parse a \"@Date:@\" header line and return the date it contains a -- 'CalendarTime'. -orig_date :: Stream s m Char => ParsecT s u m CalendarTime+orig_date :: Stream s m Char => ParsecT s u m ZonedTime orig_date = header "Date" date_time @@ -749,7 +749,7 @@ 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+-- |Parse one or more occurrences of 'qtext' or 'quoted_pair' and -- return the concatenated string. This makes up the 'id_left' of a -- 'msg_id'. @@ -760,7 +760,7 @@ return ("\"" ++ concat r ++ "\"") <?> "non-folding quoted string" --- |Parse one or more occurences of 'dtext' or 'quoted_pair' and+-- |Parse one or more occurrences of 'dtext' or 'quoted_pair' and -- return the concatenated string. This makes up the 'id_right' of a -- 'msg_id'. @@ -801,9 +801,9 @@ -- ** Resent fields (section 3.6.6) -- |Parse a \"@Resent-Date:@\" header line and return the date it--- contains as 'CalendarTime'.+-- contains as 'ZonedTime'. -resent_date :: Stream s m Char => ParsecT s u m CalendarTime+resent_date :: Stream s m Char => ParsecT s u m ZonedTime resent_date = header "Resent-Date" date_time -- |Parse a \"@Resent-From:@\" header line and return the 'mailbox_list'@@ -864,7 +864,7 @@ ) <?> "return path spec" -received :: Stream s m Char => ParsecT s u m ([(String,String)], CalendarTime)+received :: Stream s m Char => ParsecT s u m ([(String,String)], ZonedTime) received = header "Received" (do r1 <- name_val_list _ <- char ';' r2 <- date_time@@ -903,6 +903,8 @@ -- 'field_name' and 'unstructured' text of the header. The name will -- /not/ contain the terminating colon. +{-# ANN optional_field "HLint: ignore Reduce duplication" #-}+ optional_field :: Stream s m Char => ParsecT s u m (String,String) optional_field = do n <- field_name _ <- char ':'@@ -1007,8 +1009,9 @@ -- * Obsolete Date and Time (section 4.3) -- |Parse a 'day_name' but allow for the obsolete folding syntax.+-- TODO -obs_day_of_week :: Stream s m Char => ParsecT s u m Day+obs_day_of_week :: Stream s m Char => ParsecT s u m String obs_day_of_week = unfold day_name <?> "day-of-the-week name" -- |Parse a 'year' but allow for a two-digit number (obsolete) and the@@ -1026,7 +1029,7 @@ -- |Parse a 'month_name' but allow for the obsolete folding syntax. -obs_month :: Stream s m Char => ParsecT s u m Month+obs_month :: Stream s m Char => ParsecT s u m Int obs_month = between cfws cfws month_name <?> "month name" -- |Parse a 'day' but allow for the obsolete folding syntax.@@ -1051,24 +1054,24 @@ -- |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) }-+obs_zone :: Stream s m Char => ParsecT s u m TimeZone+obs_zone = choice [ parseZone "UT" 0+ , parseZone "GMT" 0+ , parseZone "EST" (-5)+ , parseZone "EDT" (-4)+ , parseZone "CST" (-6)+ , parseZone "CDT" (-5)+ , parseZone "MST" (-7)+ , parseZone "MDT" (-6)+ , parseZone "PST" (-8)+ , parseZone "PDT" (-7)+ , do { r <- oneOf ['A'..'I']; mkZone (ord r - 64) } <?> "military zone spec"+ , do { r <- oneOf ['K'..'M']; mkZone (ord r - 65) } <?> "military zone spec"+ , do { r <- oneOf ['N'..'Y']; mkZone (-(ord r - 77)) } <?> "military zone spec"+ , parseZone "Z" 0 <?> "military zone spec"+ ]+ where parseZone n o = try (string n *> mkZone o)+ mkZone = pure . hoursToTimeZone -- * Obsolete Addressing (section 4.4) @@ -1182,40 +1185,38 @@ -- * 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) })- )--+obs_fields = many $ choice+ [ try (From <$> obs_from)+ , try (Sender <$> obs_sender)+ , try (ReturnPath <$> obs_return)+ , try (ReplyTo <$> obs_reply_to)+ , try (To <$> obs_to)+ , try (Cc <$> obs_cc)+ , try (Bcc <$> obs_bcc)+ , try (MessageID <$> obs_message_id)+ , try (InReplyTo <$> obs_in_reply_to)+ , try (References <$> obs_references)+ , try (Subject <$> obs_subject)+ , try (Comments <$> obs_comments)+ , try (Keywords . return <$> obs_keywords)+ , try (Date <$> obs_orig_date)+ , try (ResentDate <$> obs_resent_date)+ , try (ResentFrom <$> obs_resent_from)+ , try (ResentSender <$> obs_resent_send)+ , try (ResentTo <$> obs_resent_to)+ , try (ResentCc <$> obs_resent_cc)+ , try (ResentBcc <$> obs_resent_bcc)+ , try (ResentMessageID <$> obs_resent_mid)+ , try (ResentReplyTo <$> obs_resent_reply)+ , try (ObsReceived <$> obs_received)+ , uncurry OptionalField <$> obs_optional -- catch all+ ] -- ** Obsolete origination date field (section 4.5.1) -- |Parse a 'date' header line but allow for the obsolete -- folding syntax. -obs_orig_date :: Stream s m Char => ParsecT s u m CalendarTime+obs_orig_date :: Stream s m Char => ParsecT s u m ZonedTime obs_orig_date = obs_header "Date" date_time @@ -1341,7 +1342,7 @@ -- |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 :: Stream s m Char => ParsecT s u m ZonedTime obs_resent_date = obs_header "Resent-Date" date_time -- |Parse a 'resent_to' header line but allow for the obsolete
− test/doctest.hs
@@ -1,6 +0,0 @@-module Main ( main ) where--import Test.DocTest--main :: IO ()-main = doctest [ "-isrc", "src" ]
test/spec.hs view
@@ -1,10 +1,12 @@ module Main ( main ) where +import Text.Parsec.Rfc2822++import Data.Time.Calendar+import Data.Time.LocalTime 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@@ -28,17 +30,17 @@ 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+ fmap zonedTimeToUTC (parseTest date_time "Fri, 21 Dec 2012 00:07:43 +0300") `shouldReturn`+ zonedTimeToUTC (ZonedTime (LocalTime (fromGregorian 2012 12 21) (TimeOfDay 0 7 43)) (hoursToTimeZone 3)) describe "Rfc2822.day" $ do it "parses a hand-picked day-of-months correctly" $ do- parseTest day "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 "does perform range checking" $ do+ parseFailure day "00"+ parseFailure day "99" it "fails properly on incomplete input" $ do parseFailure day "Mon"