|
@@ -0,0 +1,214 @@
|
|
|
+{-# 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 Encoding
|
|
|
+
|
|
|
+import Data.Time.ISO8601
|
|
|
+import Data.IP
|
|
|
+import Data.Default.Class
|
|
|
+
|
|
|
+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
|
|
|
+import SMTP.Parser.ParserTools
|
|
|
+import qualified Data.ByteString as BS
|
|
|
+import qualified Data.List as List
|
|
|
+
|
|
|
+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, _unrecognized :: [ByteString]
|
|
|
+ } deriving (Read, Show, Ord, Eq)
|
|
|
+
|
|
|
+makeLenses ''ClientIdentity
|
|
|
+makeLenses ''Metadata
|
|
|
+
|
|
|
+instance Default Metadata where
|
|
|
+ def = Metadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False []
|
|
|
+
|
|
|
+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
|
|
|
+
|
|
|
+renderMetadata :: Metadata -> Maybe ByteString
|
|
|
+renderMetadata m = BS.concat <$> serialize
|
|
|
+ where
|
|
|
+ serialize :: Maybe [ByteString]
|
|
|
+ serialize = do
|
|
|
+ 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
|
|
|
+ return $ [
|
|
|
+ "Client-Ip: ", utf8bs . show $ cid^.clientIp, "\r\n",
|
|
|
+ "Client-Port: ", utf8bs . show $ cid^.clientPort, "\r\n",
|
|
|
+ "Client-Name: ", cnm, "\r\n",
|
|
|
+ "Return-Path: ", normalAccountName $ rfm, "\r\n",
|
|
|
+ "Recv-Date: ", utf8bs . formatISO8601 $ rcv, "\r\n",
|
|
|
+ "Body-Encoding: ", utf8bs . show $ enc, "\r\n",
|
|
|
+ "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
|
|
|
+ ] ++ toStr ++ failStr ++ usrStr ++ unrec
|
|
|
+
|
|
|
+isMetadataComplete :: Metadata -> Bool
|
|
|
+isMetadataComplete = isJust . renderMetadata
|
|
|
+
|
|
|
+parseMetadata :: A.Parser Metadata
|
|
|
+parseMetadata = do
|
|
|
+ (m', h', p') <- parseFold parseField (def, Nothing, Nothing)
|
|
|
+ let i = do
|
|
|
+ h <- h'
|
|
|
+ p <- p'
|
|
|
+ return $ ClientIdentity h p
|
|
|
+ m = set clientId i m'
|
|
|
+ if isMetadataComplete m
|
|
|
+ then return m
|
|
|
+ else failParser
|
|
|
+ where
|
|
|
+ parseField :: Parser ((Metadata, Maybe IP, Maybe Int) -> (Metadata, Maybe IP, Maybe Int))
|
|
|
+ parseField = do
|
|
|
+ skipHorizontalSpace
|
|
|
+ A.choice [
|
|
|
+ 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 clientName (Just nm) m, ip, p),
|
|
|
+ do
|
|
|
+ frm <- hdr "Return-Path" parseAccountVal
|
|
|
+ return $ \(m, ip, p) -> (set mailFrom (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),
|
|
|
+ do
|
|
|
+ rfl <- hdr "Failed" (parseAddressingReason)
|
|
|
+ return $ \(m, ip, p) -> let
|
|
|
+ fld = m^.rcptFailed
|
|
|
+ in (set rcptFailed (rfl:fld) m, ip, p),
|
|
|
+ do
|
|
|
+ recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
+ return $ \(m, ip, p) -> (set recvDate (Just recv) m, ip, p),
|
|
|
+ do
|
|
|
+ enc <- hdr "Body-Encoding" parseEncodingVal
|
|
|
+ return $ \(m, ip, p) -> (set bodyEnc enc m, ip, p),
|
|
|
+ do
|
|
|
+ utf <- hdr "SMTP-UTF8" parseBoolVal
|
|
|
+ return $ \(m, ip, p) -> (set smtpUtf8 utf m, ip, p),
|
|
|
+ do
|
|
|
+ usr <- hdr "Auth-User" bsval
|
|
|
+ return $ \(m, ip, p) -> (set auth (Just usr) m, ip, p),
|
|
|
+ do
|
|
|
+ u <- entireHdr
|
|
|
+ return $ \(m, ip, p) -> let
|
|
|
+ uu = m^.unrecognized
|
|
|
+ in (set unrecognized (u:uu) m, ip, p)
|
|
|
+ ]
|
|
|
+ entireHdr :: Parser ByteString
|
|
|
+ entireHdr = do
|
|
|
+ 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 . bsutf8 $ 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 . bsutf8 $ 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)
|