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 ((<|>))
import qualified Text.StringConvert as SC

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

renderMetadataAddress :: Address -> ByteString
renderMetadataAddress add =
  BS.intercalate "; " $ (SC.s . asToURI $ add) : case seal add 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 . setSeal a . 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