diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +hsemail +======= + +[![hackage release](https://img.shields.io/hackage/v/hsemail.svg?label=hackage)](http://hackage.haskell.org/package/hsemail) +[![stackage LTS package](http://stackage.org/package/hsemail/badge/lts)](http://stackage.org/lts/package/hsemail) +[![stackage Nightly package](http://stackage.org/package/hsemail/badge/nightly)](http://stackage.org/nightly/package/hsemail) +[![travis build status](https://img.shields.io/travis/peti/hsemail/master.svg?label=travis+build)](https://travis-ci.org/peti/hsemail) diff --git a/hsemail.cabal b/hsemail.cabal --- a/hsemail.cabal +++ b/hsemail.cabal @@ -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 -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 +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 diff --git a/src/Text/Parsec/Rfc2234.hs b/src/Text/Parsec/Rfc2234.hs --- a/src/Text/Parsec/Rfc2234.hs +++ b/src/Text/Parsec/Rfc2234.hs @@ -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 diff --git a/src/Text/Parsec/Rfc2821.hs b/src/Text/Parsec/Rfc2821.hs --- a/src/Text/Parsec/Rfc2821.hs +++ b/src/Text/Parsec/Rfc2821.hs @@ -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\", - . --} + This module exports parser combinators for the grammar described in RFC2821, + \"Simple Mail Transfer Protocol\", . + -} +{-# LANGUAGE FlexibleContexts #-} + module Text.Parsec.Rfc2821 where import Text.Parsec.Rfc2234 @@ -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@ @=@ @'Mailbox' [] \"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)) diff --git a/src/Text/Parsec/Rfc2822.hs b/src/Text/Parsec/Rfc2822.hs --- a/src/Text/Parsec/Rfc2822.hs +++ b/src/Text/Parsec/Rfc2822.hs @@ -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\", - . + This module provides parsers for the grammar defined in RFC2822, + \"Internet Message Format\", . -} +{-# 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 diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main ( main ) where - -import Test.DocTest - -main :: IO () -main = doctest [ "-isrc", "src" ] diff --git a/test/spec.hs b/test/spec.hs --- a/test/spec.hs +++ b/test/spec.hs @@ -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"