walrus-backend/src/Walrus/Backend/Metadata.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Walrus.Backend.Metadata where

import Data.ByteString (ByteString)
import Data.Time.Clock (UTCTime)

import SMTP.Address
import SMTP.Account
import qualified SMTP.Mime as Mime
import SMTP.Response
import Data.Text.IsText

import Data.Time.ISO8601
import Data.IP
import Data.Default.Class

import Control.Applicative
import Control.Lens

import Text.Read (readMaybe)

import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Attoparsec.ByteString.Char8.Extras
import qualified Data.ByteString as BS
import qualified Data.List as List

data BackendAction = DATA deriving (Show, Read, Eq, Ord, Bounded, Enum)
data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)

data MaybeMetadata = MaybeMetadata {_mclientId :: Maybe ClientIdentity, _mclientName :: Maybe ByteString,
                                    _mmailFrom :: Maybe Account, _mrcptTo :: [Address], _mrcptFailed :: [(Address, Response)],
                                    _mauth :: Maybe ByteString, _mrecvDate :: Maybe UTCTime, _mbodyEnc :: Mime.BodyEncoding,
                                    _msmtpUtf8 :: Bool, _maction :: Maybe BackendAction, _munrecognized :: [ByteString]
                                   } deriving (Show, Ord, Eq)

data Metadata = Metadata {_clientId :: ClientIdentity, _clientName :: ByteString,
                          _mailFrom :: Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
                          _auth :: Maybe ByteString, _recvDate :: UTCTime, _bodyEnc :: Mime.BodyEncoding,
                          _smtpUtf8 :: Bool, _action :: BackendAction, _unrecognized :: [ByteString]
                         } deriving (Show, Ord, Eq)

makeLenses ''ClientIdentity
makeLenses ''MaybeMetadata
makeLenses ''Metadata

instance Default MaybeMetadata where
  def = MaybeMetadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []

metadataForClient :: IP -> Int -> MaybeMetadata
metadataForClient c p = def & mclientId .~ (Just (ClientIdentity c p))
resetMetadata :: MaybeMetadata -> MaybeMetadata
resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName

strictMetadata :: MaybeMetadata -> Maybe Metadata
strictMetadata m = do
  act <- m^.maction
  cid <- m^.mclientId
  cnm <- m^.mclientName
  rfm <- m^.mmailFrom
  let rto = m^.mrcptTo
      rfail = m^.mrcptFailed
      usr = m^.mauth
  rcv <- m^.mrecvDate
  let enc = m^.mbodyEnc
      utf = m^.msmtpUtf8
      unrq = m^.munrecognized
  return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq

renderMetadata :: Metadata -> ByteString
renderMetadata m = BS.concat serialize
  where
    serialize :: [ByteString]
    serialize = let
      act = m^.action
      cid = m^.clientId
      cnm = m^.clientName
      rfm = m^.mailFrom
      rto = m^.rcptTo
      rfail = m^.rcptFailed
      usr = m^.auth
      rcv = m^.recvDate
      enc = m^.bodyEnc
      utf = m^.smtpUtf8
      usrStr = case usr of
        Nothing -> []
        Just u -> ["Auth-User: ", u, "\r\n"]
      toStr = List.concat $ map (\x -> ["To: ", renderMetadataAddress $ x, "\r\n"]) rto
      failStr = List.concat $ map (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderResponse r, "\r\n"]) rfail
      unrec = m^.unrecognized
      h = [
        "Action: ", show act, "\r\n",
        "Client-Ip: ", show $ cid^.clientIp, "\r\n",
        "Client-Port: ", show $ cid^.clientPort, "\r\n",
        "Client-Name: ", fromText cnm, "\r\n",
        "Return-Path: ", fromText . normalAccountName $ rfm, "\r\n",
        "Recv-Date: ", formatISO8601 $ rcv, "\r\n",
        "Body-Encoding: ", show $ enc, "\r\n",
        "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
        ] :: [String]
      in map fromText h ++ toStr ++ failStr ++ usrStr ++ unrec

parseMetadata :: A.Parser Metadata
parseMetadata = do
  (m', h', p') <- parserFold parseField (def, Nothing, Nothing)
  A.endOfLine
  let i = do
        h <- h'
        p <- p'
        return $ ClientIdentity h p
      m = set mclientId i m'
  case strictMetadata m of
    Just s -> return s
    Nothing -> failParser
  where
    parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
    parseField = do
      skipHorizontalSpace
      A.choice [
        do
          act <- hdr "Action" parseEnumCI
          return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
        do
          ip <- hdr "Client-Ip" parseRead
          return $ \(m, _, p) -> (m, ip, p),
        do
          p <- hdr "Client-Port" parseRead
          return $ \(m, ip, _) -> (m, ip, p),
        do
          nm <- hdr "Client-Name" bsval
          return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
        do
          frm <- hdr "Return-Path" parseAccountVal
          return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
        do
          rtp <- hdr "To" parseAddressingVal
          return $ \(m, ip, p) -> let
            crtp = m^.mrcptTo
            in (set mrcptTo (rtp:crtp) m, ip, p),
        do
          rfl <- hdr "Failed" (parseAddressingReason)
          return $ \(m, ip, p) -> let
            fld = m^.mrcptFailed
            in (set mrcptFailed (rfl:fld) m, ip, p),
        do
          recv <- hdr "Recv-Date" parseISO8601Val
          return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
        do
          enc <- hdr "Body-Encoding" parseEncodingVal
          return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
        do
          utf <- hdr "SMTP-UTF8" parseBoolVal
          return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
        do
          usr <- hdr "Auth-User" bsval
          return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
        do
          u <- entireHdr
          return $ \(m, ip, p) -> let
            uu = m^.munrecognized
            in (set munrecognized (u:uu) m, ip, p)
        ]
    entireHdr :: Parser ByteString
    entireHdr = do
      A.satisfy (not . A.isEndOfLine . asW8)
      t <- A.takeTill (A.isEndOfLine . asW8)
      A.endOfLine
      l <- takeLines
      return $ BS.concat [t, "\r\n", l]
    takeLines :: Parser ByteString
    takeLines = do
      c' <- A.peekChar
      case c' of
        Nothing -> return ""
        Just c -> if isCHorizontalSpace c
                  then do
                    l <- A.takeTill (A.isEndOfLine . asW8)
                    A.endOfLine
                    ll <- takeLines
                    return $ BS.concat [l, "\r\n", ll]
                   else return ""
    hdr :: ByteString -> Parser a -> Parser a
    hdr pt f = do
      skipHorizontalSpace
      A.stringCI pt
      skipHorizontalSpace
      A.char ':'
      skipHorizontalSpace
      r <- f
      skipHorizontalSpace
      A.endOfLine
      return r
    bsval :: Parser ByteString
    bsval = do
      v <- A.takeTill (A.isEndOfLine . asW8)
      A.endOfLine
      c' <- A.peekChar
      case c' of
        Nothing -> return v
        Just c -> if isCHorizontalSpace c
                  then do
                    v' <- bsval
                    return $ BS.concat [v, " ", v']
                  else return v
    parseRead :: Read a => Parser a
    parseRead = do
      v <- bsval
      case readMaybe . fromText $ v of
        Nothing -> failParser
        Just i -> return i
    parseVal :: Parser a -> Parser a
    parseVal p = do
      v <- bsval
      case A.parseOnly p v of
        Left _ -> failParser
        Right v' -> return v'
    parseAccountVal = parseVal parseAccount
    parseAddressingVal = parseVal parseMetadataAddress
    parseEncodingVal = parseVal Mime.parseBodyEncoding
    parseBoolVal = parseVal parseMetadataBool
    parseISO8601Val = do
      v <- bsval
      case parseISO8601 . fromText $ v of
        Nothing -> failParser
        Just t -> return t
    parseMetadataBool :: Parser Bool
    parseMetadataBool = do
      A.choice [
        A.stringCI "YES" *> return True,
        A.stringCI "NO" *> return False
        ]
    parseAddressingReason :: Parser (Address, Response)
    parseAddressingReason = do
      a <- parseMetadataAddress
      skipHorizontalSpace
      A.char ';'
      skipHorizontalSpace
      r <- parseResponse
      return (a, r)