{-# LANGUAGE OverloadedLists #-} 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 import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Data.ByteString import qualified Data.ByteString as T import qualified Data.Vector as V import Data.Email.Header import qualified Data.ByteString.Char8 as BC genHeader :: Gen Header genHeader = Gen.choice [ From <$> genEmail , To . V.fromList <$> Gen.list (Range.linear 0 10) genEmail ] genEmail :: Gen ByteString genEmail = do name <- Gen.element Corpus.simpsons domain <- Gen.element Corpus.cooking tld <- Gen.element ["com","fi","org"] pure $ name <> "@" <> domain <> "." <> tld wrapped :: Char -> ByteString -> Char -> ByteString wrapped l x r = BC.singleton l <> x <> BC.singleton r genComment :: Gen ByteString genComment = do x <- Gen.element Corpus.simpsons Gen.element [x, wrapped '"' 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 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 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" [ 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 , testCase "can parse sourcehut" $ decode "From: sourcehut " @?= Right (From "outgoing@sr.ht") ]