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

74 lines
2.3 KiB
Haskell
Raw Normal View History

2020-12-10 21:24:23 +02:00
{-# LANGUAGE OverloadedLists #-}
2020-12-10 21:08:48 +02:00
module Test.Data.Email.Header where
import Test.Tasty
import Test.Tasty.Hedgehog
2020-12-10 21:38:32 +02:00
import Test.Tasty.HUnit
2020-12-10 21:08:48 +02:00
import Hedgehog
import qualified Hedgehog.Corpus as Corpus
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
2021-10-29 22:39:27 +03:00
import Data.ByteString
import qualified Data.ByteString as T
2020-12-10 21:08:48 +02:00
import qualified Data.Vector as V
import Data.Email.Header
2021-10-29 22:39:27 +03:00
import qualified Data.ByteString.Char8 as BC
2020-12-10 21:08:48 +02:00
genHeader :: Gen Header
genHeader = Gen.choice
[ From <$> genEmail
, To . V.fromList <$> Gen.list (Range.linear 0 10) genEmail
]
2020-12-10 21:24:23 +02:00
2021-10-29 22:39:27 +03:00
genEmail :: Gen ByteString
2020-12-10 21:24:23 +02:00
genEmail = do
name <- Gen.element Corpus.simpsons
domain <- Gen.element Corpus.cooking
tld <- Gen.element ["com","fi","org"]
pure $ name <> "@" <> domain <> "." <> tld
2021-10-29 22:39:27 +03:00
wrapped :: Char -> ByteString -> Char -> ByteString
wrapped l x r = BC.singleton l <> x <> BC.singleton r
2020-12-10 21:38:32 +02:00
2021-10-29 22:39:27 +03:00
genComment :: Gen ByteString
2020-12-10 21:24:23 +02:00
genComment = do
x <- Gen.element Corpus.simpsons
2020-12-10 21:38:32 +02:00
Gen.element [x, wrapped '"' x '"']
2020-12-10 21:08:48 +02:00
prop_roundtrip_parse :: Property
prop_roundtrip_parse = property $ do
header <- forAll genHeader
tripping header encode decode
2020-12-10 21:24:23 +02:00
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
2020-12-10 21:38:32 +02:00
let line = "From: " <> comment <> " " <> wrapped '<' email '>'
annotateShow line
decode line === Right (From email)
2020-12-10 21:24:23 +02:00
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
2020-12-10 21:38:32 +02:00
let line = "To: " <> T.intercalate ", " (fmap (\(e,c) -> c <> " " <> wrapped '<' e '>') emails)
annotateShow line
decode line === Right (To wanted)
2020-12-10 21:24:23 +02:00
2020-12-10 21:08:48 +02:00
tests :: TestTree
tests = testGroup "Data.Email.Header"
2020-12-10 21:24:23 +02:00
[ 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
2020-12-10 21:38:32 +02:00
, testCase "can parse sourcehut" $ decode "From: sourcehut <outgoing@sr.ht>" @?= Right (From "outgoing@sr.ht")
2020-12-10 21:24:23 +02:00
]