{-# 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.Text.IsText 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.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] } 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] } 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 [] 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 return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq 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 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, "; ", renderResponse 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: ", fromText cnm, "\r\n", "Return-Path: ", fromText . 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" ] :: [String] in map fromText 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 skipHorizontalSpace 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, ip, p), do p <- hdr "Client-Port" parseRead return $ \(m, ip, _) -> (m, ip, p), do nm <- hdr "Client-Name" bsval return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p), do frm <- hdr "Return-Path" parseAccountVal return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p), do rtp <- hdr "To" parseAddressingVal 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" parseEncodingVal return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p), do utf <- hdr "SMTP-UTF8" parseBoolVal 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 u <- entireHdr return $ \(m, ip, p) -> let uu = m^.munrecognized in (set munrecognized (u:uu) m, ip, p) ] entireHdr :: Parser ByteString entireHdr = do A.satisfy (not . A.isEndOfLine . asW8) t <- A.takeTill (A.isEndOfLine . asW8) A.endOfLine l <- takeLines return $ BS.concat [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 r <- f skipHorizontalSpace A.endOfLine return r bsval :: Parser ByteString bsval = do v <- A.takeTill (A.isEndOfLine . asW8) A.endOfLine c' <- A.peekChar case c' of Nothing -> return v Just c -> if isCHorizontalSpace c then do v' <- bsval return $ BS.concat [v, " ", v'] else return v parseRead :: Read a => Parser a parseRead = do v <- bsval case readMaybe . fromText $ v of Nothing -> failParser Just i -> return i parseVal :: Parser a -> Parser a parseVal p = do v <- bsval case A.parseOnly p v of Left _ -> failParser Right v' -> return v' parseAccountVal = parseVal parseAccount parseAddressingVal = parseVal parseMetadataAddress parseEncodingVal = parseVal Mime.parseBodyEncoding parseBoolVal = parseVal parseMetadataBool parseISO8601Val = do v <- bsval case parseISO8601 . fromText $ 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 <- parseResponse return (a, r)