|
@@ -20,7 +20,6 @@ import Control.Applicative
|
|
|
import Control.Lens
|
|
|
|
|
|
import Text.Read (readMaybe)
|
|
|
-import Data.Maybe (isJust)
|
|
|
|
|
|
import Data.Attoparsec.ByteString.Char8 (Parser)
|
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
@@ -31,78 +30,98 @@ 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 Metadata = Metadata {_clientId :: Maybe ClientIdentity, _clientName :: Maybe ByteString,
|
|
|
- _mailFrom :: Maybe Account, _rcptTo :: [Address], _rcptFailed :: [(Address, Response)],
|
|
|
- _auth :: Maybe ByteString, _recvDate :: Maybe UTCTime, _bodyEnc :: Mime.BodyEncoding,
|
|
|
- _smtpUtf8 :: Bool, _action :: Maybe BackendAction, _unrecognized :: [ByteString]
|
|
|
+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 Metadata where
|
|
|
- def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing []
|
|
|
+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
|
|
|
|
|
|
-metadataForClient :: IP -> Int -> Metadata
|
|
|
-metadataForClient c p = def & clientId .~ (Just (ClientIdentity c p))
|
|
|
-resetMetadata :: Metadata -> Metadata
|
|
|
-resetMetadata d = def & clientId .~ d^.clientId & clientName .~ d^.clientName
|
|
|
+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 -> Maybe ByteString
|
|
|
-renderMetadata m = BS.concat . map fromText <$> serialize
|
|
|
+renderMetadata :: Metadata -> ByteString
|
|
|
+renderMetadata m = BS.concat serialize
|
|
|
where
|
|
|
- serialize :: Maybe [ByteString]
|
|
|
- serialize = do
|
|
|
- act <- m^.action
|
|
|
- cid <- m^.clientId
|
|
|
- cnm <- m^.clientName
|
|
|
- rfm <- m^.mailFrom
|
|
|
- let rto = m^.rcptTo
|
|
|
- rfail = m^.rcptFailed
|
|
|
- usr = m^.auth
|
|
|
- rcv <- m^.recvDate
|
|
|
- let enc = m^.bodyEnc
|
|
|
- utf = m^.smtpUtf8
|
|
|
- usrStr = case usr of
|
|
|
- Nothing -> []
|
|
|
- Just u -> ["Auth-User: ", u, "\r\n"]
|
|
|
- let 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
|
|
|
- let unrec = m^.unrecognized
|
|
|
- let 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]
|
|
|
- return $ map fromText h ++ toStr ++ failStr ++ usrStr ++ unrec
|
|
|
-
|
|
|
-isMetadataComplete :: Metadata -> Bool
|
|
|
-isMetadataComplete = isJust . renderMetadata
|
|
|
+ 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 clientId i m'
|
|
|
- if isMetadataComplete m
|
|
|
- then return m
|
|
|
- else failParser
|
|
|
+ m = set mclientId i m'
|
|
|
+ case strictMetadata m of
|
|
|
+ Just s -> return s
|
|
|
+ Nothing -> failParser
|
|
|
where
|
|
|
- parseField :: Parser ((Metadata, Maybe IP, Maybe Int) -> (Metadata, Maybe IP, Maybe Int))
|
|
|
+ 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 action (Just act) m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set maction (Just act) m, ip, p),
|
|
|
do
|
|
|
ip <- hdr "Client-Ip" parseRead
|
|
|
return $ \(m, _, p) -> (m, ip, p),
|
|
@@ -111,40 +130,41 @@ parseMetadata = do
|
|
|
return $ \(m, ip, _) -> (m, ip, p),
|
|
|
do
|
|
|
nm <- hdr "Client-Name" bsval
|
|
|
- return $ \(m, ip, p) -> (set clientName (Just nm) m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set mclientName (Just nm) m, ip, p),
|
|
|
do
|
|
|
frm <- hdr "Return-Path" parseAccountVal
|
|
|
- return $ \(m, ip, p) -> (set mailFrom (Just frm) m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
|
|
|
do
|
|
|
rtp <- hdr "To" parseAddressingVal
|
|
|
return $ \(m, ip, p) -> let
|
|
|
- crtp = m^.rcptTo
|
|
|
- in (set rcptTo (rtp:crtp) m, ip, p),
|
|
|
+ crtp = m^.mrcptTo
|
|
|
+ in (set mrcptTo (rtp:crtp) m, ip, p),
|
|
|
do
|
|
|
rfl <- hdr "Failed" (parseAddressingReason)
|
|
|
return $ \(m, ip, p) -> let
|
|
|
- fld = m^.rcptFailed
|
|
|
- in (set rcptFailed (rfl:fld) m, ip, p),
|
|
|
+ fld = m^.mrcptFailed
|
|
|
+ in (set mrcptFailed (rfl:fld) m, ip, p),
|
|
|
do
|
|
|
recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
- return $ \(m, ip, p) -> (set recvDate (Just recv) m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
|
|
|
do
|
|
|
enc <- hdr "Body-Encoding" parseEncodingVal
|
|
|
- return $ \(m, ip, p) -> (set bodyEnc enc m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set mbodyEnc enc m, ip, p),
|
|
|
do
|
|
|
utf <- hdr "SMTP-UTF8" parseBoolVal
|
|
|
- return $ \(m, ip, p) -> (set smtpUtf8 utf m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set msmtpUtf8 utf m, ip, p),
|
|
|
do
|
|
|
usr <- hdr "Auth-User" bsval
|
|
|
- return $ \(m, ip, p) -> (set auth (Just usr) m, ip, p),
|
|
|
+ return $ \(m, ip, p) -> (set mauth (Just usr) m, ip, p),
|
|
|
do
|
|
|
u <- entireHdr
|
|
|
return $ \(m, ip, p) -> let
|
|
|
- uu = m^.unrecognized
|
|
|
- in (set unrecognized (u:uu) m, ip, p)
|
|
|
+ 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
|