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 Text.StringConvert

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

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

-- | All the actions that walrus may request from a backend
data BackendAction =
  -- | Recieve new resource
  DELIVER |
  -- | Verify if a backend will handle the rcpt to addresses
  WILLHANDLE |
  -- | Verifies if accounts exist as in the SMTP VRFY command
  VERIFY |
  -- | Fetch a resource
  FETCH |
  -- | Delete a resource
  DELETE deriving (Show, Read, Eq, Ord, Bounded, Enum)

-- | The network data of a client (IP and port)
data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)

-- | A possibly empty version of Metadata for iterative filling. Convert with strictMetadata.
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)

-- | All the data of a backend metadata, as the walrus specification.
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

-- | Creates an empty metadata with just the client identity
metadataForClient :: IP -> Int -> MaybeMetadata
metadataForClient c p = def & mclientId .~ Just (ClientIdentity c p)
-- | Blanks the data as necessary for the RSET SMTP command
resetMetadata :: MaybeMetadata -> MaybeMetadata
resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName

-- | Converts a fully filled MaybeMetadata into its strict version
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

-- | Converts the metadata to text on the format required by walrus backends.
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.concatMap (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
      failStr = List.concatMap (\(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: ", s cnm, "\r\n",
        "Return-Path: ", s . 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 s h ++ toStr ++ failStr ++ usrStr ++ unrec ++ ["\r\n"]

-- | Reads a metadata from a textual representation on the format expected by the walrus backends
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 sm -> return sm
    Nothing -> fail "missing required fields"
  where
    parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
    parseField = 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" A.takeByteString
        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 _ -> fail $ "failed parsing value of " ++ s pt
        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 . s $ v of
        Nothing -> fail "failed parsing value"
        Just i -> return i
    parseISO8601Val = do
      v <- A.takeTill A.isSpace
      case parseISO8601 . s $ v of
        Nothing -> fail "failed parsing ISO8601 date"
        Just t -> return t
    parseMetadataBool :: Parser Bool
    parseMetadataBool = 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)