Fix the email comment format

addressbook.cabal

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

default.nix

@@ -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;
 }

src/Data/Email/Header.hs

@@ -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

test/Test/Data/Email/Header.hs

@@ -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")
   ]