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

{-# 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 <outgoing@sr.ht>" @?= Right (From "outgoing@sr.ht")
  ]