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 Data.SMTP.Address (Address)
import qualified Data.SMTP.Address as Add
import Data.SMTP.Account
--import qualified Data.SMTP.URI as URI
import qualified Data.SMTP.Mime as Mime
import Data.SMTP.Response
import qualified Text.StringConvert as SC

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 Data.SMTP.VRFY command
  VERIFY |
  -- | Fetch a resource
  FETCH
  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 :: [Account], _mrcptFailed :: [(Account, 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 Response,
                                    _mftchRecursive :: Bool, _mftchHeaders :: Bool, _mftchQuery :: FtchQuery,
                                    _mftchOffset :: Int, _mftchSize :: Maybe Int
                                   } deriving (Show, Ord, Eq)

uq :: Eq a => (b -> a) -> b -> b -> Bool
uq f a b = f a == f b

sq :: Ord a => (b -> [a]) -> b -> b -> Bool
sq f a b = (List.sort . f $ a) == (List.sort . f $ b)

-- | 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)
instance Eq Metadata where
  a == b = let
    u f = uq f a b
    s f = sq f a b
    in and [u _clientId, u _auth, u _recvDate, u _dataSize, u _actionData] &&
       s _unrecognized

data ActionData = Deliver DeliverData |
                  WillHandle AccountData |
                  Verify AccountData |
                  FetchResc FetchRescData |
                  FetchHdr FetchHdrData
                deriving (Show, Ord, Eq)

data DeliverData = DeliverData {clientName :: ByteString,
                                mailFrom :: Account, rcptTo :: [Account], rcptFailed :: [(Account, Response)],
                                bodyEnc :: Mime.BodyEncoding, smtpUtf8 :: Bool
                               }  deriving (Show, Ord)
instance Eq DeliverData where
    a == b = let
      u f = uq f a b
      s f = sq f a b
      in and [u clientName, u mailFrom, u bodyEnc, u smtpUtf8] &&
         and [s rcptTo, s rcptFailed]

data AccountData = AccountRequest Account |
                   AccountResponse (Account, Response) |
                   AccountOk deriving (Show, Ord, Eq)

{- |
Data for fetching resource:

@
FetchRescData clientName account offset size target_or_error
@
-}
data FetchRescData =
  FetchRescData
  -- Client name
  ByteString
  -- From account
  Account
  -- Offset
  Int
  -- Size
  Int
  -- Target
  Address
  -- Fetch result
  (Maybe Response)
  deriving (Show, Ord, Eq)
{- |
Data for fetching headers:

@
FetchHdrData clientName account onlyHeaders query
@
-}
data FetchHdrData =
  FetchHdrData
  -- Client name
  ByteString
  -- From account
  Account
  -- Only headers
  Bool
  -- Query
  FtchQuery
  -- Target
  Address
  -- Fetch result
  (Maybe Response)
  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 Data.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
    FETCH -> if headers
             then m' <$> FetchHdr <$> getFetchHdr
             else m' <$> FetchResc <$> getFetchResc
    WILLHANDLE -> m' <$> WillHandle <$> getAccountData
    VERIFY -> m' <$> Verify <$> getAccountData
  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
    getAccountData :: Maybe AccountData
    getAccountData = let
      rto = m^.mrcptTo
      rfail = m^.mrcptFailed
      in case rto of
        (t:_) -> return $ AccountRequest t
        [] -> case rfail of
          (f:_) -> return $ AccountResponse f
          [] -> return $ AccountOk
    getFetchResc :: Maybe FetchRescData
    getFetchResc = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let ofst = m^.mftchOffset
      sz <- m^.mftchSize
      trg <- m^.mtargetResc
      let resp = m^.mtargetFailure
      return $ FetchRescData cnm rfm ofst sz trg resp
    getFetchHdr :: Maybe FetchHdrData
    getFetchHdr = do
      cnm <- m^.mclientName
      rfm <- m^.mmailFrom
      let r = m^.mftchRecursive
          q = m^.mftchQuery
      trg <- m^.mtargetResc
      let resp = m^.mtargetFailure
      return $ FetchHdrData cnm rfm r q trg resp
      

-- | 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 SC.s h ++ usrStr ++ unrec
    serializeDt = case m^.actionData of
      Deliver dt -> "Action: DELIVER\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: ", fullAccount x, "\r\n"]) rto
      failStr = List.concatMap (\(a, r) -> ["Failed: ", fullAccount a, "; ", renderLineResponse r, "\r\n"]) rfail
      h = [
        "Client-Name: ", SC.s cnm, "\r\n",
        "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
        "Body-Encoding: ", show enc, "\r\n",
        "SMTP-UTF8: ", serialBool utf, "\r\n"
        ] :: [String]
      in map SC.s h ++ toStr ++ failStr
    serializeHandle (AccountRequest a) = ["To: ", SC.s . fullAccount $ a, "\r\n"]
    serializeHandle (AccountResponse (a, r)) = ["Failed: ", fullAccount a, "; ", renderLineResponse r, "\r\n"]
    serializeHandle AccountOk = []
    serializeFetchResc (FetchRescData cnm rfm ofst sz trg resp) =
      ["Client-Name: ", SC.s cnm, "\r\n",
       "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
       "Headers: No\r\n",
       "Offset: ", SC.s . show $ ofst, "\r\n",
       "Block-Size: ", SC.s . show $ sz, "\r\n",
       "Target: ", SC.s . show $ trg, "\r\n"] ++
      case resp of
        Nothing -> []
        Just r -> ["Failure: ", renderLineResponse r, "\r\n"]
    serializeFetchHdr (FetchHdrData cnm rfm r q trg resp) =
      ["Client-Name: ", SC.s cnm, "\r\n",
       "Return-Path: ", SC.s . normalize $ rfm, "\r\n",
       "Headers: Yes\r\n",
       "Recursive: ", serialBool r, "\r\n",
       "Query: ", serializeFtchQuery q, "\r\n",
       "Target: ", SC.s . show $ trg, "\r\n"] ++
      case resp of
        Nothing -> []
        Just rs -> ["Failure: ", renderLineResponse rs, "\r\n"]
    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" parseAccount
        return $ \(m, ip, p) -> let
          crtp = m^.mrcptTo
          in (set mrcptTo (rtp:crtp) m, ip, p),
      do
        resc <- hdr "Target" Add.parseAddress
        return $ \(m, ip, p) -> (set mtargetResc (Just resc) m, ip, p),
      do
        rfl <- hdr "Failed" parseAccountReason
        return $ \(m, ip, p) -> let
          fld = m^.mrcptFailed
          in (set mrcptFailed (rfl:fld) m, ip, p),
      do
        e <- hdr "Failure" parseLineResponse
        return $ \(m, ip, p) -> (set mtargetFailure (Just e) 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 " ++ SC.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 . SC.s $ v of
        Nothing -> fail "failed parsing value"
        Just i -> return i
    parseISO8601Val = do
      v <- A.takeTill A.isSpace
      case parseISO8601 . SC.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
      ]
    parseAccountReason :: Parser (Account, Response)
    parseAccountReason = do
      a <- parseAccount
      skipHorizontalSpace
      A.char ';'
      skipHorizontalSpace
      r <- parseLineResponse
      return (a, r)

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

getTo :: Metadata -> [Account]
getTo Metadata{_actionData=act} = case act of
  Deliver dt -> rcptTo dt
  WillHandle dt -> hdl dt
  Verify dt -> hdl dt
  FetchResc (FetchRescData _ _ _ _ dt _) -> [Add.account dt]
  FetchHdr (FetchHdrData _ _ _ _ dt _) -> [Add.account dt]
  where
    hdl (AccountRequest a) = [a]
    hdl _ = []

getHandle :: Metadata -> Maybe AccountData
getHandle Metadata{_actionData=act} = case act of
  WillHandle dt -> Just dt
  Verify dt -> Just dt
  _ -> Nothing