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 Debug.Trace

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, _mtargetResc :: Maybe Address, _mtargetFailure :: Maybe (Address, Response)
                                   } deriving (Show, Ord, Eq)

-- | All the data of a backend metadata, as the walrus specification.
data Metadata = Metadata {_clientId :: ClientIdentity, _auth :: Maybe ByteString,
                          _recvDate :: UTCTime, _unrecognized :: [ByteString],
                          _dataSize :: Int, _actionData :: ActionData} deriving (Show, Ord, Eq)

data ActionData = Deliver DeliverData |
                  WillHandle HandleData |
                  Verify HandleData |
                  Fetch FetchData |
                  Delete DeliverData deriving (Show, Ord, Eq)

data DeliverData = DeliverData {clientName :: ByteString,
                                mailFrom :: Account, rcptTo :: [Address], rcptFailed :: [(Address, Response)],
                                bodyEnc :: Mime.BodyEncoding, smtpUtf8 :: Bool
                               }  deriving (Show, Ord, Eq)
data HandleData = HandleAddress Address |
                  HandleResponse (Address, Response) |
                  HandleOk deriving (Show, Ord, Eq)
data FetchData = FetchData
  -- | Client name
  ByteString
  -- | From account
  Account
  -- | Target or fetch error
  HandleData 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 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
  let usr = m^.mauth
  rcv <- m^.mrecvDate
  let unrq = m^.munrecognized
  sz <- m^.mdataSize
  let m' = Metadata cid usr rcv unrq sz
  case act of
    DELIVER -> m' <$> Deliver <$> getDeliverData
    DELETE -> m' <$> Delete <$> getDeliverData
    FETCH -> m' <$> Fetch <$> getFetchData
    WILLHANDLE -> m' <$> WillHandle <$> getHandleData
    VERIFY -> m' <$> Verify <$> getHandleData
  where
    getDeliverData :: Maybe DeliverData
    getDeliverData = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let rto = m^.mrcptTo
          rfail = m^.mrcptFailed
          enc = m^.mbodyEnc
          utf = m^.msmtpUtf8
      return $ DeliverData cnm rfm rto rfail enc utf
    getHandleData :: Maybe HandleData
    getHandleData = let
      rto = m^.mrcptTo
      rfail = m^.mrcptFailed
      in case rto of
        (t:_) -> return $ HandleAddress t
        [] -> case rfail of
          (f:_) -> return $ HandleResponse f
          [] -> return $ HandleOk
    getFetchData :: Maybe FetchData
    getFetchData = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let m' = FetchData cnm rfm
      case m^.mtargetResc of
        Just t -> return . m' $ HandleAddress t
        Nothing -> case m^.mtargetFailure of
          Just f -> return . m' $ HandleResponse f
          Nothing -> return . m' $ HandleOk

-- | Converts the metadata to text on the format required by walrus backends.
renderMetadata :: Metadata -> ByteString
renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
  where
    serializeMain :: [ByteString]
    serializeMain = let
      cid = m^.clientId
      usr = m^.auth
      rcv = m^.recvDate
      sz = m^.dataSize
      usrStr = case usr of
        Nothing -> []
        Just u -> ["Auth-User: ", u, "\r\n"]
      unrec = m^.unrecognized
      h = [
        "Client-Ip: ", show $ cid^.clientIp, "\r\n",
        "Client-Port: ", show $ cid^.clientPort, "\r\n",
        "Recv-Date: ", formatISO8601 rcv, "\r\n",
        "Data-Size: ", show sz, "\r\n"
        ] :: [String]
      in map s h ++ usrStr ++ unrec
    serializeDt = case m^.actionData of
      Deliver dt -> "Action: DELIVER\r\n" : serializeDeliver dt
      Delete dt -> "Action: DELETE\r\n" : serializeDeliver dt
      WillHandle dt -> "Action: WILLHANDLE\r\n" : serializeHandle dt
      Verify dt -> "Action: VERIFY\r\n" : serializeHandle dt
      Fetch dt -> "Action: FETCH\r\n" : serializeFetch dt
    serializeDeliver d = let
      cnm = clientName d
      rfm = mailFrom d
      rto = rcptTo d
      rfail = rcptFailed d
      enc = bodyEnc d
      utf = smtpUtf8 d
      toStr = List.concatMap (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
      failStr = List.concatMap (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]) rfail
      h = [
        "Client-Name: ", s cnm, "\r\n",
        "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
        "Body-Encoding: ", show enc, "\r\n",
        "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
        ] :: [String]
      in map s h ++ toStr ++ failStr
    serializeHandle (HandleAddress a) = ["To: ", renderMetadataAddress a, "\r\n"]
    serializeHandle (HandleResponse (a, r)) = ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]
    serializeHandle HandleOk = []
    serializeFetch (FetchData cnm rfm hnd) =
      ["Client-Name: ", s cnm, "\r\n",
       "Return-Path: ", s . normalAccountName $ rfm, "\r\n"] ++
      serializeHandle hnd


-- | 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) $ set mtargetResc (Just rtp) m, ip, p),
      do
        rfl <- hdr "Failed" parseAddressingReason
        return $ \(m, ip, p) -> let
          fld = m^.mrcptFailed
          in (set mrcptFailed (rfl:fld) $ set mtargetFailure (Just rfl) 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)

getDeliver :: (DeliverData -> a) -> Metadata -> Maybe a
getDeliver f Metadata{_actionData=act} = case act of
  Deliver dt -> Just $ f dt
  Delete dt -> Just $ f dt
  _ -> Nothing

getTo :: Metadata -> [Address]
getTo Metadata{_actionData=act} = case act of
  Deliver dt -> rcptTo dt
  Delete dt -> rcptTo dt
  WillHandle dt -> hdl dt
  Verify dt -> hdl dt
  Fetch (FetchData _ _ dt) -> hdl dt
  where
    hdl (HandleAddress a) = [a]
    hdl _ = []

getHandle :: Metadata -> Maybe HandleData
getHandle Metadata{_actionData=act} = case act of
  WillHandle dt -> Just dt
  Verify dt -> Just dt
  Fetch (FetchData _ _ dt) -> Just dt
  _ -> Nothing