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)

data FtchQuery = FtchQueryAll deriving (Eq, Ord, Show, Read)

-- | 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),
                                    _mftchRecursive :: Bool, _mftchHeaders :: Bool, _mftchQuery :: FtchQuery,
                                    _mftchOffset :: Int, _mftchSize :: Maybe Int
                                   } 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 |
                  FetchResc FetchRescData |
                  FetchHdr FetchHdrData |
                  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 FetchRescData = FetchRescData
  -- | Client name
  ByteString
  -- | From account
  Account
  -- | Offset
  Int
  -- | Size
  Int
  -- | Target or fetch error
  HandleData deriving (Show, Ord, Eq)
data FetchHdrData = FetchHdrData
  -- | Client name
  ByteString
  -- | From account
  Account
  -- | Only headers
  Bool
  -- | Query
  FtchQuery
  -- | 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
        False False FtchQueryAll 0 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
      headers = m^.mftchHeaders
  case act of
    DELIVER -> m' <$> Deliver <$> getDeliverData
    DELETE -> m' <$> Delete <$> getDeliverData
    FETCH -> if headers
             then m' <$> FetchHdr <$> getFetchHdr
             else m' <$> FetchResc <$> getFetchResc
    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
    getFetchResc :: Maybe FetchRescData
    getFetchResc = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let ofst = m^.mftchOffset
      sz <- m^.mftchSize
      return $ FetchRescData cnm rfm ofst sz getFetchHandle
    getFetchHdr :: Maybe FetchHdrData
    getFetchHdr = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let r = m^.mftchRecursive
          q = m^.mftchQuery
      return $ FetchHdrData cnm rfm r q getFetchHandle
    getFetchHandle = case m^.mtargetResc of
      Just t -> HandleAddress t
      Nothing -> case m^.mtargetFailure of
        Just f -> HandleResponse f
        Nothing -> 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
      FetchResc dt -> "Action: FETCH\r\n" : serializeFetchResc dt
      FetchHdr dt -> "Action: FETCH\r\n": serializeFetchHdr 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: ", serialBool utf, "\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 = []
    serializeFetchResc (FetchRescData cnm rfm ofst sz hnd) =
      ["Client-Name: ", s cnm, "\r\n",
       "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
       "Headers: No\r\n",
       "Offset: ", s . show $ ofst, "\r\n",
       "Block-Size: ", s . show $ sz, "\r\n"] ++
      serializeHandle hnd
    serializeFetchHdr (FetchHdrData cnm rfm r q hnd) =
      ["Client-Name: ", s cnm, "\r\n",
       "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
       "Headers: Yes\r\n",
       "Recursive: ", serialBool r, "\r\n",
       "Query: ", serializeFtchQuery q, "\r\n"] ++
      serializeHandle hnd
    serialBool b = if b then "Yes" else "No"

serializeFtchQuery :: FtchQuery -> ByteString
serializeFtchQuery _ = "()"

parseFtchQuery :: A.Parser FtchQuery
parseFtchQuery = A.string "()" >> return FtchQueryAll

-- | 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
        off <- hdr "Offset" A.decimal
        return $ \(m, ip, p) -> (m &mftchOffset.~off, ip, p),
      do
        sz <- hdr "Block-Size" A.decimal
        return $ \(m, ip, p) -> (m &mftchSize.~Just sz, ip, p),
      do
        h <- hdr "Headers" parseMetadataBool
        return $ \(m, ip, p) -> (m &mftchHeaders.~h, ip, p),
      do
        r <- hdr "Recursive" parseMetadataBool
        return $ \(m, ip, p) -> (m &mftchRecursive.~r, ip, p),
      do
        q <- hdr "Query" parseFtchQuery
        return $ \(m, ip, p) -> (m &mftchQuery.~q, 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
  FetchResc (FetchRescData _ _ _ _ dt) -> hdl dt
  FetchHdr (FetchHdrData _ _ _ _ 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
  FetchResc (FetchRescData _ _ _ _ dt) -> Just dt
  FetchHdr (FetchHdrData _ _ _ _ dt) -> Just dt
  _ -> Nothing