diff --git a/addressbook.cabal b/addressbook.cabal index ccc9627..d5e11f0 100644 --- a/addressbook.cabal +++ b/addressbook.cabal @@ -18,8 +18,11 @@ extra-source-files: CHANGELOG.md library exposed-modules: MyLib + , Data.Email.Header -- other-modules: -- other-extensions: + default-extensions: OverloadedStrings + LambdaCase build-depends: base ^>=4.13.0.0 , attoparsec , mtl @@ -27,6 +30,7 @@ library , pipes-bytestring , text , bytestring-trie + , vector hs-source-dirs: src default-language: Haskell2010 @@ -40,6 +44,9 @@ executable addressbook test-suite addressbook-test default-language: Haskell2010 + default-extensions: OverloadedStrings + LambdaCase + other-modules: Test.Data.Email.Header type: exitcode-stdio-1.0 hs-source-dirs: test main-is: MyLibTest.hs @@ -48,3 +55,6 @@ test-suite addressbook-test , tasty , tasty-hedgehog , hedgehog + , hedgehog-corpus + , text + , vector diff --git a/default.nix b/default.nix index 3cedc8e..aa3c8a5 100644 --- a/default.nix +++ b/default.nix @@ -1,5 +1,6 @@ -{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog, mtl -, pipes, pipes-bytestring, stdenv, tasty, tasty-hedgehog, text +{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog +, hedgehog-corpus, mtl, pipes, pipes-bytestring, stdenv, tasty +, tasty-hedgehog, text, vector }: mkDerivation { pname = "addressbook"; @@ -9,8 +10,11 @@ mkDerivation { isExecutable = true; libraryHaskellDepends = [ attoparsec base bytestring-trie mtl pipes pipes-bytestring text + vector ]; executableHaskellDepends = [ base ]; - testHaskellDepends = [ base hedgehog tasty tasty-hedgehog ]; + testHaskellDepends = [ + base hedgehog hedgehog-corpus tasty tasty-hedgehog + ]; license = stdenv.lib.licenses.bsd3; } diff --git a/src/Data/Email/Header.hs b/src/Data/Email/Header.hs index 5936302..c773a3e 100644 --- a/src/Data/Email/Header.hs +++ b/src/Data/Email/Header.hs @@ -41,6 +41,7 @@ decode = parseOnly parseHeader name <- T.pack <$> many' (notChar '@') _ <- char '@' rest <- T.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',')) + _ <- many' (notChar ',') pure (name <> "@" <> rest) diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs index 3e2059e..c31a9ee 100644 --- a/test/MyLibTest.hs +++ b/test/MyLibTest.hs @@ -1,4 +1,13 @@ module Main (main) where +import Test.Tasty + +import qualified Test.Data.Email.Header as Data.Email.Header + +tests :: TestTree +tests = testGroup "tests" + [ Data.Email.Header.tests + ] + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = defaultMain tests diff --git a/test/Test/Data/Email/Header.hs b/test/Test/Data/Email/Header.hs index b261a93..2e5fd71 100644 --- a/test/Test/Data/Email/Header.hs +++ b/test/Test/Data/Email/Header.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} module Test.Data.Email.Header where import Test.Tasty @@ -9,6 +10,7 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Data.Text +import qualified Data.Text as T import qualified Data.Vector as V import Data.Email.Header @@ -18,19 +20,44 @@ genHeader = Gen.choice [ From <$> genEmail , To . V.fromList <$> Gen.list (Range.linear 0 10) genEmail ] - where - genEmail :: Gen Text - genEmail = do - name <- Gen.element Corpus.simpsons - domain <- Gen.element Corpus.cooking - tld <- Gen.element ["com","fi","org"] - pure $ name <> "@" <> domain <> "." <> tld + +genEmail :: Gen Text +genEmail = do + name <- Gen.element Corpus.simpsons + domain <- Gen.element Corpus.cooking + tld <- Gen.element ["com","fi","org"] + pure $ name <> "@" <> domain <> "." <> tld + +genComment :: Gen Text +genComment = do + x <- Gen.element Corpus.simpsons + Gen.element [ "<" <> x <> ">", "(" <> x <> ")" ] prop_roundtrip_parse :: Property prop_roundtrip_parse = property $ do header <- forAll genHeader tripping header encode decode +prop_parse_from :: Property +prop_parse_from = property $ do + email <- forAll genEmail + decode ("From: " <> email) === Right (From email) + +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) + +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) + tests :: TestTree tests = testGroup "Data.Email.Header" - [ testProperty "roundtrip property" $ prop_roundtrip_parse ] + [ testProperty "roundtrip property" $ prop_roundtrip_parse + , 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 + ]