Fix the email comment format

This commit is contained in:
Mats Rauhala 2020-12-10 21:38:32 +02:00
parent b483ccb3f4
commit 98ec13e0cd
4 changed files with 24 additions and 8 deletions

View File

@ -54,6 +54,8 @@ test-suite addressbook-test
, addressbook
, tasty
, tasty-hedgehog
, tasty-hunit
, HUnit
, hedgehog
, hedgehog-corpus
, text

View File

@ -1,6 +1,6 @@
{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog
, hedgehog-corpus, mtl, pipes, pipes-bytestring, stdenv, tasty
, tasty-hedgehog, text, vector
, hedgehog-corpus, HUnit, mtl, pipes, pipes-bytestring, stdenv
, tasty, tasty-hedgehog, tasty-hunit, text, vector
}:
mkDerivation {
pname = "addressbook";
@ -14,7 +14,8 @@ mkDerivation {
];
executableHaskellDepends = [ base ];
testHaskellDepends = [
base hedgehog hedgehog-corpus tasty tasty-hedgehog
base hedgehog hedgehog-corpus HUnit tasty tasty-hedgehog
tasty-hunit text vector
];
license = stdenv.lib.licenses.bsd3;
}

View File

@ -29,12 +29,16 @@ decode = parseOnly parseHeader
parseHeader :: Parser Header
parseHeader = parseFrom <|> parseTo
parseFrom :: Parser Header
parseFrom = From <$> (string "From:" *> emptySpace *> email)
parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email))
parseTo :: Parser Header
parseTo = To <$> (string "To:" *> emptySpace *> emails)
emptySpace = many' space
emails :: Parser (Vector Text)
emails = V.fromList <$> email `sepBy` char ','
emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ','
bracketEmail :: Parser Text
bracketEmail = do
_ <- manyTill anyChar (char '<')
T.pack <$> manyTill anyChar (char '>')
email :: Parser Text
email = do
_ <- many' space

View File

@ -3,6 +3,7 @@ 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
@ -28,10 +29,13 @@ genEmail = do
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 <> ">", "(" <> x <> ")" ]
Gen.element [x, wrapped '"' x '"']
prop_roundtrip_parse :: Property
prop_roundtrip_parse = property $ do
@ -46,13 +50,17 @@ prop_parse_from = property $ do
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)
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
decode ("To: " <> T.intercalate ", " (fmap (\(e,c) -> e <> " " <> c) emails)) === Right (To wanted)
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"
@ -60,4 +68,5 @@ tests = testGroup "Data.Email.Header"
, 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")
]