diff --git a/addressbook.cabal b/addressbook.cabal index d5e11f0..75ca429 100644 --- a/addressbook.cabal +++ b/addressbook.cabal @@ -54,6 +54,8 @@ test-suite addressbook-test , addressbook , tasty , tasty-hedgehog + , tasty-hunit + , HUnit , hedgehog , hedgehog-corpus , text diff --git a/default.nix b/default.nix index aa3c8a5..e120e20 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ { mkDerivation, attoparsec, base, bytestring-trie, hedgehog -, hedgehog-corpus, mtl, pipes, pipes-bytestring, stdenv, tasty -, tasty-hedgehog, text, vector +, hedgehog-corpus, HUnit, mtl, pipes, pipes-bytestring, stdenv +, tasty, tasty-hedgehog, tasty-hunit, text, vector }: mkDerivation { pname = "addressbook"; @@ -14,7 +14,8 @@ mkDerivation { ]; executableHaskellDepends = [ base ]; testHaskellDepends = [ - base hedgehog hedgehog-corpus tasty tasty-hedgehog + base hedgehog hedgehog-corpus HUnit tasty tasty-hedgehog + tasty-hunit text vector ]; license = stdenv.lib.licenses.bsd3; } diff --git a/src/Data/Email/Header.hs b/src/Data/Email/Header.hs index c773a3e..58f6a50 100644 --- a/src/Data/Email/Header.hs +++ b/src/Data/Email/Header.hs @@ -29,12 +29,16 @@ decode = parseOnly parseHeader parseHeader :: Parser Header parseHeader = parseFrom <|> parseTo parseFrom :: Parser Header - parseFrom = From <$> (string "From:" *> emptySpace *> email) + parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email)) parseTo :: Parser Header parseTo = To <$> (string "To:" *> emptySpace *> emails) emptySpace = many' space emails :: Parser (Vector Text) - emails = V.fromList <$> email `sepBy` char ',' + emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ',' + bracketEmail :: Parser Text + bracketEmail = do + _ <- manyTill anyChar (char '<') + T.pack <$> manyTill anyChar (char '>') email :: Parser Text email = do _ <- many' space diff --git a/test/Test/Data/Email/Header.hs b/test/Test/Data/Email/Header.hs index 2e5fd71..bc58f71 100644 --- a/test/Test/Data/Email/Header.hs +++ b/test/Test/Data/Email/Header.hs @@ -3,6 +3,7 @@ module Test.Data.Email.Header where import Test.Tasty import Test.Tasty.Hedgehog +import Test.Tasty.HUnit import Hedgehog import qualified Hedgehog.Corpus as Corpus @@ -28,10 +29,13 @@ genEmail = do tld <- Gen.element ["com","fi","org"] pure $ name <> "@" <> domain <> "." <> tld +wrapped :: Char -> Text -> Char -> Text +wrapped l x r = T.singleton l <> x <> T.singleton r + genComment :: Gen Text genComment = do x <- Gen.element Corpus.simpsons - Gen.element [ "<" <> x <> ">", "(" <> x <> ")" ] + Gen.element [x, wrapped '"' x '"'] prop_roundtrip_parse :: Property prop_roundtrip_parse = property $ do @@ -46,13 +50,17 @@ prop_parse_from = property $ do prop_parse_from_and_comments :: Property prop_parse_from_and_comments = property $ do (email, comment) <- forAll $ (,) <$> genEmail <*> genComment - decode ("From: " <> email <> " " <> comment) === Right (From email) + let line = "From: " <> comment <> " " <> wrapped '<' email '>' + annotateShow line + decode line === Right (From email) prop_parse_to_and_comments :: Property prop_parse_to_and_comments = property $ do emails <- forAll $ Gen.list (Range.linear 1 10) ((,) <$> genEmail <*> genComment) let wanted = V.fromList $ fmap fst emails - decode ("To: " <> T.intercalate ", " (fmap (\(e,c) -> e <> " " <> c) emails)) === Right (To wanted) + let line = "To: " <> T.intercalate ", " (fmap (\(e,c) -> c <> " " <> wrapped '<' e '>') emails) + annotateShow line + decode line === Right (To wanted) tests :: TestTree tests = testGroup "Data.Email.Header" @@ -60,4 +68,5 @@ tests = testGroup "Data.Email.Header" , testProperty "any email can be read as from" $ prop_parse_from , testProperty "any email with comments can be parsed" $ prop_parse_from_and_comments , testProperty "any list of emails with comments can be parsed" $ prop_parse_to_and_comments + , testCase "can parse sourcehut" $ decode "From: sourcehut " @?= Right (From "outgoing@sr.ht") ]