Fix bug in parser

src/Control/Addressbook/Streaming.hs

@@ -29,6 +29,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBC
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Control.Parallel.Strategies (rseq, parMap)
 import qualified Data.List as L
+import Control.Monad (unless)
 
 combine :: (MonadUnliftIO m, MonadResource m, MonadThrow m, MonadIO m) => ConduitM FilePath Header m ()
 combine = await >>= \case
@@ -46,7 +47,8 @@ run = do
   let datFile = datDir </> ".addressbook.dat"
   original <- Set.fromList . map LBS.toStrict . lbsLines <$> LBS.readFile datFile
   xs <- LBS.getContents >>= stream
-  let set = original `Set.union` F.fold (parMap rseq F.fold (chunks 20 xs))
+  let set = original `Set.union` F.fold (parMap rseq F.fold (chunks 200 xs))
+  unless (original == set) $
     runResourceT $
       runConduit $
            CL.sourceList (Set.elems set)

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
+{-# 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 = many' space
+
+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 /= '>'))
+  rest <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',' && c /= '>' && c /= '<'))
   _ <- many' (notChar ',')
   pure (name <> "@" <> rest)
+{-# INLINE email #-}
 
 
 encode :: Header -> ByteString

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