{-# 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)