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

{-# LANGUAGE OverloadedStrings #-}

module Data.SMTP.Parser.Address (
  parseAddress,
  parseMetadataAddress,
  renderMetadataAddress
  ) where

import Data.Attoparsec.ByteString.Char8
import qualified Data.SMTP.URI as URI
import Data.SMTP.Account
import Data.SMTP.Types.Address
import qualified Data.SMTP.Seal as Seal
import Data.Attoparsec.ByteString.Char8.Extras
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import Control.Applicative ((<|>))

parseAddress :: Parser Address
parseAddress = ((\x -> Address (Just x) (URI.account x) Nothing) <$> URI.parseURI) <|>
               ((\x -> Address Nothing x Nothing) <$> parseAccount)

renderMetadataAddress :: Address -> ByteString
renderMetadataAddress add@(Address _ _ s) =
  BS.intercalate "; " $ asToURI add : case s of
    Nothing -> []
    Just (Seal.Seal cp code nonce) -> [
      BS.append "CP=" $ B64.encode cp
      ] ++ nc nonce ++ [
      BS.append "SEAL=" $ B64.encode code
      ]
  where
    nc nonce = case nonce of
      Nothing -> []
      Just n -> [BS.append "Nonce=" $ B64.encode n]

parseMetadataAddress :: Parser Address
parseMetadataAddress = do
  a <- parseAddress
  (cp, nonce, code) <- parserFold addrParams (Nothing, Nothing, Nothing)
  let r = do
        cp' <- cp
        code' <- code
        return a{seal=Just $ Seal.Seal cp' code' nonce}
  case r of
    Nothing -> return a
    Just r' -> return r'
  where
    addrParams = choice [
      do
        c <- cmdSep "CP" decodeBase64
        return $ \(_, n, s) -> (Just c, n, s),
      do
        n <- cmdSep "Nonce" decodeBase64
        return $ \(c, _, s) -> (c, Just n, s),
      do
        s <- cmdSep "Seal" decodeBase64
        return $ \(c, n, _) -> (c, n, Just s)
      ]
    cmdSep c p = do
      skipWhile isCHorizontalSpace
      stringCI c
      skipWhile isCHorizontalSpace
      char ':'
      skipWhile isCHorizontalSpace
      p