diff --git a/Text/ParserCombinators/Parsec/Rfc2822.hs b/Text/ParserCombinators/Parsec/Rfc2822.hs --- a/Text/ParserCombinators/Parsec/Rfc2822.hs +++ b/Text/ParserCombinators/Parsec/Rfc2822.hs @@ -10,8 +10,6 @@ This module provides parsers for the grammar defined in RFC2822, \"Internet Message Format\", . - - /Please note:/ The module is not particularly well tested. -} module Text.ParserCombinators.Parsec.Rfc2822 where @@ -19,10 +17,14 @@ 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 @@ -326,11 +328,16 @@ <|> do { caseString "Dec"; return December } "month name" --- |Match either an 'obs_day', or a one or two digit number and return it. +-- 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 (do { optional fws; r <- manyNtoM 1 2 digit; return (read r :: Int) }) <|> obs_day - "day" +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 @@ -1027,7 +1034,7 @@ -- |Parse a 'day' but allow for the obsolete folding syntax. obs_day :: CharParser a Int -obs_day = unfold day "day" +obs_day = unfold day_of_month "day" -- |Parse a 'hour' but allow for the obsolete folding syntax. @@ -1114,8 +1121,7 @@ r2 <- many (do _ <- cfws <|> string "," optional cfws _ <- char '@' - r <- domain - return r) + domain) return (r1 : r2) "route of an obsolete angle address" @@ -1166,7 +1172,7 @@ _ <- unfold $ char ',' return r)) r2 <- maybeOption mailbox - return [x | Just x <- r1 ++ [r2]] + return (catMaybes (r1 ++ [r2])) "obsolete syntax for a list of mailboxes" -- |This parser is identical to 'obs_mbox_list' but parses a list of @@ -1182,7 +1188,7 @@ optional cfws return r)) r2 <- maybeOption address - return (concat [x | Just x <- r1 ++ [r2]]) + return (concat (catMaybes (r1 ++ [r2]))) "obsolete syntax for a list of addresses" @@ -1386,7 +1392,7 @@ -- ** Obsolete trace fields (section 4.5.7) -obs_return :: CharParser a [Char] +obs_return :: CharParser a String obs_return = obs_header "Return-Path" path obs_received :: CharParser a [(String, String)] diff --git a/hsemail.cabal b/hsemail.cabal --- a/hsemail.cabal +++ b/hsemail.cabal @@ -1,5 +1,5 @@ Name: hsemail -Version: 1.7.2 +Version: 1.7.3 Copyright: (c) 2012 Peter Simons License: BSD3 License-File: LICENSE @@ -9,9 +9,9 @@ Category: Parsing Synopsis: Internet Message Parsers Description: Parsers for the syntax defined in RFC2821 and 2822 -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple -Tested-With: GHC == 7.0.4, GHC == 7.4.1 +Tested-With: GHC >= 7.0.4 && <= 7.6.1 Extra-Source-Files: example/message-test.hs example/message-test.input @@ -28,3 +28,8 @@ Text.ParserCombinators.Parsec.Rfc2821 Text.ParserCombinators.Parsec.Rfc2822 Ghc-Options: -Wall + +Test-Suite test-hsemail + type: exitcode-stdio-1.0 + main-is: self-test.hs + build-depends: base, hspec, parsec, old-time diff --git a/self-test.hs b/self-test.hs new file mode 100644 --- /dev/null +++ b/self-test.hs @@ -0,0 +1,49 @@ +module Main ( main ) where + +import Test.Hspec +import System.Time ( CalendarTime(..), Month(..), Day(..) ) +import Text.ParserCombinators.Parsec ( parse, CharParser ) +import Text.ParserCombinators.Parsec.Rfc2822 + +parseTest :: CharParser () a -> String -> IO a +parseTest p input = case parse p "" input of + Left err -> fail ("parse error at " ++ show err) + Right r -> return r + +parseFailure :: (Show a) => CharParser () a -> String -> Expectation +parseFailure p input = parse p "" input `shouldSatisfy` failure + where + failure (Left _) = True + failure _ = False + +main :: IO () +main = hspec $ do + describe "Rfc822.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 "Rfc822.day" $ + 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 + + describe "Rfc822.day" $ + it "does not perform range checking" $ + parseTest day "99" `shouldReturn` 99 + + describe "Rfc822.day" $ + it "fails properly on incomplete input" $ do + parseFailure day "Mon" + parseFailure day "Thu" + + describe "Rfc822.obs_mbox_list" $ + 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"] + + describe "Rfc822.obs_mbox_list" $ + it "fails properly on incomplete input" $ + parseFailure obs_mbox_list "foo@example.org"