fcmtp-data/src/Data/SMTP/Parser/Account.hs

{-# LANGUAGE OverloadedStrings #-}
-- Parser of email account

module Data.SMTP.Parser.Account where

import Data.SMTP.Types.Account
import Data.Attoparsec.ByteString.Char8.Extras
import Data.SMTP.Parser.Host

import Control.Applicative ((<|>))
import Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Search as Search
import Data.ByteString (ByteString)
import qualified Codec.Binary.UTF8.String as UTF8
import qualified Data.Char as C
import qualified Data.Word8 as W

parseAccount :: Parser Account
parseAccount = quotedAccount <|> escapedAccount <|> plainAccount

quotedAccount :: Parser Account
quotedAccount = do
  char '\"'
  a <- parseAccount
  char '\"'
  return a

plainAccount :: Parser Account
plainAccount = do
  (fa, AccountName a, h, ts) <- plainAddress
  if BS.null a
    then fail "empty account name"
    else return $ Account fa (PersonalName "") (AccountName a) h ts
    
escapedAccount :: Parser Account
escapedAccount = do
  n' <- takeTill (`elem` ("\"'<\r\n" :: String))
  let n = fst . BS.spanEnd W.isSpace $ n'
  char '<'
  (fa, a, h, ts) <- plainAddress
  char '>'
  return $ Account (BS.concat [n', "<", fa, ">"]) (PersonalName n) a h ts
 
plainAddress :: Parser (ByteString, AccountName, HostName, [AccountTag])
plainAddress = do
  (fa, a, ts) <- scanAccountName
  (h, hasAt) <-
    (do
        char '@'
        h <- scanHostName
        return (h, True)
    ) <|> return ("", False)
  return (if hasAt then BS.concat [fa, "@", h] else fa, a, HostName h, ts)

scanAccountName :: Parser (ByteString, AccountName, [AccountTag])
scanAccountName = do
  f <- quotedString '\\' " ][,:\\;<>\"\r\n@" "\r\n"
  let ff = Search.split "+" f
  case ff of
    [] -> return (f, normalizeA f, [])
    [_] -> return (f, normalizeA f, [])
    (a:aa) -> return (f, normalizeA a, map AccountTag aa)
    
normalizeA :: ByteString -> AccountName
normalizeA a = AccountName na
  where
    a' = LBS.unpack $ Search.replace ("([^)]*)"::ByteString) (""::ByteString) a
    a'' = UTF8.encode . map C.toLower . UTF8.decode $ a'
    na = BS.pack a''