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