addressbook/test/Test/Data/Email/Header.hs

73 lines
2.3 KiB
Haskell

{-# 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.Text
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Email.Header
genHeader :: Gen Header
genHeader = Gen.choice
[ From <$> genEmail
, To . V.fromList <$> Gen.list (Range.linear 0 10) genEmail
]
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
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, 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 <outgoing@sr.ht>" @?= Right (From "outgoing@sr.ht")
]