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.Textual.Class

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.ByteString.Char8 as C8
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],
                                    _mdataSize :: Maybe Int
                                   } 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],
                          _dataSize :: Int
                         } 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 [] 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
  sz <- m^.mdataSize
  return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq sz

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
      sz = m^.dataSize
      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, renderLineResponse 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: ", fromTextual cnm, "\r\n",
        "Return-Path: ", fromTextual . 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",
        "Data-Size: ", show sz, "\r\n"
        ] :: [String]
      in map fromTextual 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
      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, Just ip, p),
        do
          p <- hdr "Client-Port" parseRead
          return $ \(m, ip, _) -> (m, ip, Just p),
        do
          nm <- hdr "Client-Name" (A.takeTill A.isSpace)
          return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
        do
          frm <- hdr "Return-Path" parseAccount
          return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
        do
          rtp <- hdr "To" parseAddress
          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" Mime.parseBodyEncoding
          return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
        do
          utf <- hdr "SMTP-UTF8" parseMetadataBool
          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
          sz <- hdr "Data-Size" A.decimal
          return $ \(m, ip, p) -> (set mdataSize (Just sz) 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 <- A.satisfy (not . A.isEndOfLine . asW8)
      t <- A.takeTill (A.isEndOfLine . asW8)
      A.endOfLine
      l <- takeLines
      return $ BS.concat [C8.cons a 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
      t <- bsval
      r <- case A.parseOnly f t of
        Left _ -> failParser
        Right v -> return v
      skipHorizontalSpace
      return r
    bsval :: Parser ByteString
    bsval = do
      ll <- entireHdr
      let (b, _) = BS.spanEnd (\x -> x == asW8 '\r' || x == asW8 '\n') ll
      return b
    parseRead :: Read a => Parser a
    parseRead = do
      v <- A.takeTill A.isSpace
      case readMaybe . fromTextual $ v of
        Nothing -> failParser
        Just i -> return i
    parseISO8601Val = do
      v <- A.takeTill A.isSpace
      case parseISO8601 . fromTextual $ 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 <- parseLineResponse
      return (a, r)