From 5182c47a196dc82e69eec3544b23a743fddb240a Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Thu, 4 Nov 2021 10:24:22 +0200
Subject: [PATCH] Fix bug in parser

---
 src/Data/Email/Header.hs | 56 ++++++++++++++++++++++++----------------
 test/Test/Data/Email.hs  |  3 +++
 2 files changed, 37 insertions(+), 22 deletions(-)

diff --git a/src/Data/Email/Header.hs b/src/Data/Email/Header.hs
index 6c3d918..0b46114 100644
--- a/src/Data/Email/Header.hs
+++ b/src/Data/Email/Header.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ApplicativeDo #-}
 module Data.Email.Header where
 
 import qualified Data.Foldable as F
@@ -21,28 +22,39 @@ data Header
 
 decode :: ByteString -> Either String Header
 decode = parseOnly parseHeader
-  where
-    parseHeader :: Parser Header
-    parseHeader = parseFrom <|> parseTo
-    parseFrom :: Parser Header
-    parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email))
-    parseTo :: Parser Header
-    parseTo = To <$> (string "To:" *> emptySpace *> emails)
-    emptySpace = many' space
-    emails :: Parser (Vector ByteString)
-    emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ','
-    bracketEmail :: Parser ByteString
-    bracketEmail = do
-      _ <- manyTill anyChar (char '<')
-      email
-    email :: Parser ByteString
-    email = do
-      _ <- many' space
-      name <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= '@'))
-      _ <- char '@'
-      rest <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',' && c /= '>'))
-      _ <- many' (notChar ',')
-      pure (name <> "@" <> rest)
+{-# INLINE decode #-}
+
+parseHeader :: Parser Header
+parseHeader = parseFrom <|> parseTo
+{-# INLINE parseHeader #-}
+
+parseFrom :: Parser Header
+parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email))
+
+parseTo :: Parser Header
+parseTo = To <$> (string "To:" *> emptySpace *> emails)
+
+emptySpace :: Parser ()
+emptySpace = () <$ many' space
+
+emails :: Parser (Vector ByteString)
+emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ','
+
+bracketEmail :: Parser ByteString
+bracketEmail = do
+  _ <- manyTill anyChar (char '<')
+  email
+{-# INLINE bracketEmail #-}
+
+email :: Parser ByteString
+email = do
+  _ <- many' space
+  name <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= '@'))
+  _ <- char '@'
+  rest <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',' && c /= '>' && c /= '<'))
+  _ <- many' (notChar ',')
+  pure (name <> "@" <> rest)
+{-# INLINE email #-}
 
 
 encode :: Header -> ByteString
diff --git a/test/Test/Data/Email.hs b/test/Test/Data/Email.hs
index 09fa95f..af7ba53 100644
--- a/test/Test/Data/Email.hs
+++ b/test/Test/Data/Email.hs
@@ -31,4 +31,7 @@ tests = testGroup "Data.Email"
   [ testCase "Can parse a sample email" $ do
       got <- parseToList sample
       got @?= [ From "me@example.com", To ["you@example.com"]]
+  , testCase "Combined mailto" $ do
+      let got = decode "To: James Doe<james.doe@example.com<mailto:james.doe@example.com>>"
+      got @?= Right (To ["james.doe@example.com"])
   ]