addressbook/src/Data/Email/Header.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
module Data.Email.Header where

import qualified Data.Foldable as F

import Data.Attoparsec.ByteString.Char8

import Data.Vector
       (Vector)
import qualified Data.Vector as V

import Control.Applicative
       ((<|>))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC

data Header
  = From !ByteString
  | To !(Vector ByteString)
  deriving (Show, Eq)

decode :: ByteString -> Either String Header
decode = parseOnly parseHeader
{-# 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
encode = \case
  From addr -> "From: " <> addr
  To addrs -> "To: " <> BC.intercalate ", " (F.toList addrs)