|
@@ -20,6 +20,8 @@ import Control.Lens
|
|
|
|
|
|
import Text.Read (readMaybe)
|
|
|
|
|
|
+import Debug.Trace
|
|
|
+
|
|
|
import Data.Attoparsec.ByteString.Char8 (Parser)
|
|
|
import qualified Data.Attoparsec.ByteString.Char8 as A
|
|
|
import Data.Attoparsec.ByteString.Char8.Extras
|
|
@@ -48,23 +50,41 @@ data MaybeMetadata = MaybeMetadata {_mclientId :: Maybe ClientIdentity, _mclient
|
|
|
_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
|
|
|
+ _mdataSize :: Maybe Int, _mtargetResc :: Maybe Address, _mtargetFailure :: Maybe (Address, Response)
|
|
|
} deriving (Show, Ord, Eq)
|
|
|
|
|
|
-- | All the data of a backend metadata, as the walrus specification.
|
|
|
-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)
|
|
|
+data Metadata = Metadata {_clientId :: ClientIdentity, _auth :: Maybe ByteString,
|
|
|
+ _recvDate :: UTCTime, _unrecognized :: [ByteString],
|
|
|
+ _dataSize :: Int, _actionData :: ActionData} deriving (Show, Ord, Eq)
|
|
|
+
|
|
|
+data ActionData = Deliver DeliverData |
|
|
|
+ WillHandle HandleData |
|
|
|
+ Verify HandleData |
|
|
|
+ Fetch FetchData |
|
|
|
+ Delete DeliverData deriving (Show, Ord, Eq)
|
|
|
+
|
|
|
+data DeliverData = DeliverData {clientName :: ByteString,
|
|
|
+ mailFrom :: Account, rcptTo :: [Address], rcptFailed :: [(Address, Response)],
|
|
|
+ bodyEnc :: Mime.BodyEncoding, smtpUtf8 :: Bool
|
|
|
+ } deriving (Show, Ord, Eq)
|
|
|
+data HandleData = HandleAddress Address |
|
|
|
+ HandleResponse (Address, Response) |
|
|
|
+ HandleOk deriving (Show, Ord, Eq)
|
|
|
+data FetchData = FetchData
|
|
|
+ -- | Client name
|
|
|
+ ByteString
|
|
|
+ -- | From account
|
|
|
+ Account
|
|
|
+ -- | Target or fetch error
|
|
|
+ HandleData 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
|
|
|
+ def = MaybeMetadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing [] Nothing Nothing Nothing
|
|
|
|
|
|
-- | Creates an empty metadata with just the client identity
|
|
|
metadataForClient :: IP -> Int -> MaybeMetadata
|
|
@@ -78,53 +98,98 @@ 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
|
|
|
+ let usr = m^.mauth
|
|
|
rcv <- m^.mrecvDate
|
|
|
- let enc = m^.mbodyEnc
|
|
|
- utf = m^.msmtpUtf8
|
|
|
- unrq = m^.munrecognized
|
|
|
+ let unrq = m^.munrecognized
|
|
|
sz <- m^.mdataSize
|
|
|
- return $ Metadata cid cnm rfm rto rfail usr rcv enc utf act unrq sz
|
|
|
+ let m' = Metadata cid usr rcv unrq sz
|
|
|
+ case act of
|
|
|
+ DELIVER -> m' <$> Deliver <$> getDeliverData
|
|
|
+ DELETE -> m' <$> Delete <$> getDeliverData
|
|
|
+ FETCH -> m' <$> Fetch <$> getFetchData
|
|
|
+ WILLHANDLE -> m' <$> WillHandle <$> getHandleData
|
|
|
+ VERIFY -> m' <$> Verify <$> getHandleData
|
|
|
+ where
|
|
|
+ getDeliverData :: Maybe DeliverData
|
|
|
+ getDeliverData = do
|
|
|
+ cnm <- m^.mclientName
|
|
|
+ rfm <- m^.mmailFrom
|
|
|
+ let rto = m^.mrcptTo
|
|
|
+ rfail = m^.mrcptFailed
|
|
|
+ enc = m^.mbodyEnc
|
|
|
+ utf = m^.msmtpUtf8
|
|
|
+ return $ DeliverData cnm rfm rto rfail enc utf
|
|
|
+ getHandleData :: Maybe HandleData
|
|
|
+ getHandleData = let
|
|
|
+ rto = m^.mrcptTo
|
|
|
+ rfail = m^.mrcptFailed
|
|
|
+ in case rto of
|
|
|
+ (t:_) -> return $ HandleAddress t
|
|
|
+ [] -> case rfail of
|
|
|
+ (f:_) -> return $ HandleResponse f
|
|
|
+ [] -> return $ HandleOk
|
|
|
+ getFetchData :: Maybe FetchData
|
|
|
+ getFetchData = do
|
|
|
+ cnm <- m^.mclientName
|
|
|
+ rfm <- m^.mmailFrom
|
|
|
+ let m' = FetchData cnm rfm
|
|
|
+ case m^.mtargetResc of
|
|
|
+ Just t -> return . m' $ HandleAddress t
|
|
|
+ Nothing -> case m^.mtargetFailure of
|
|
|
+ Just f -> return . m' $ HandleResponse f
|
|
|
+ Nothing -> return . m' $ HandleOk
|
|
|
|
|
|
-- | Converts the metadata to text on the format required by walrus backends.
|
|
|
renderMetadata :: Metadata -> ByteString
|
|
|
-renderMetadata m = BS.concat serialize
|
|
|
+renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
|
|
|
where
|
|
|
- serialize :: [ByteString]
|
|
|
- serialize = let
|
|
|
- act = m^.action
|
|
|
+ serializeMain :: [ByteString]
|
|
|
+ serializeMain = let
|
|
|
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.concatMap (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
|
|
|
- failStr = List.concatMap (\(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",
|
|
|
+ "Recv-Date: ", formatISO8601 rcv, "\r\n",
|
|
|
+ "Data-Size: ", show sz, "\r\n"
|
|
|
+ ] :: [String]
|
|
|
+ in map s h ++ usrStr ++ unrec
|
|
|
+ serializeDt = case m^.actionData of
|
|
|
+ Deliver dt -> "Action: DELIVER\r\n" : serializeDeliver dt
|
|
|
+ Delete dt -> "Action: DELETE\r\n" : serializeDeliver dt
|
|
|
+ WillHandle dt -> "Action: WILLHANDLE\r\n" : serializeHandle dt
|
|
|
+ Verify dt -> "Action: VERIFY\r\n" : serializeHandle dt
|
|
|
+ Fetch dt -> "Action: FETCH\r\n" : serializeFetch dt
|
|
|
+ serializeDeliver d = let
|
|
|
+ cnm = clientName d
|
|
|
+ rfm = mailFrom d
|
|
|
+ rto = rcptTo d
|
|
|
+ rfail = rcptFailed d
|
|
|
+ enc = bodyEnc d
|
|
|
+ utf = smtpUtf8 d
|
|
|
+ toStr = List.concatMap (\x -> ["To: ", renderMetadataAddress x, "\r\n"]) rto
|
|
|
+ failStr = List.concatMap (\(a, r) -> ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]) rfail
|
|
|
+ h = [
|
|
|
"Client-Name: ", s cnm, "\r\n",
|
|
|
"Return-Path: ", s . 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"
|
|
|
+ "SMTP-UTF8: ", if utf then "Yes" else "No", "\r\n"
|
|
|
] :: [String]
|
|
|
- in map s h ++ toStr ++ failStr ++ usrStr ++ unrec ++ ["\r\n"]
|
|
|
+ in map s h ++ toStr ++ failStr
|
|
|
+ serializeHandle (HandleAddress a) = ["To: ", renderMetadataAddress a, "\r\n"]
|
|
|
+ serializeHandle (HandleResponse (a, r)) = ["Failed: ", renderMetadataAddress a, "; ", renderLineResponse r, "\r\n"]
|
|
|
+ serializeHandle HandleOk = []
|
|
|
+ serializeFetch (FetchData cnm rfm hnd) =
|
|
|
+ ["Client-Name: ", s cnm, "\r\n",
|
|
|
+ "Return-Path: ", s . normalAccountName $ rfm, "\r\n"] ++
|
|
|
+ serializeHandle hnd
|
|
|
+
|
|
|
|
|
|
-- | Reads a metadata from a textual representation on the format expected by the walrus backends
|
|
|
parseMetadata :: A.Parser Metadata
|
|
@@ -161,12 +226,12 @@ parseMetadata = do
|
|
|
rtp <- hdr "To" parseAddress
|
|
|
return $ \(m, ip, p) -> let
|
|
|
crtp = m^.mrcptTo
|
|
|
- in (set mrcptTo (rtp:crtp) m, ip, p),
|
|
|
+ in (set mrcptTo (rtp:crtp) $ set mtargetResc (Just rtp) m, ip, p),
|
|
|
do
|
|
|
rfl <- hdr "Failed" parseAddressingReason
|
|
|
return $ \(m, ip, p) -> let
|
|
|
fld = m^.mrcptFailed
|
|
|
- in (set mrcptFailed (rfl:fld) m, ip, p),
|
|
|
+ in (set mrcptFailed (rfl:fld) $ set mtargetFailure (Just rfl) m, ip, p),
|
|
|
do
|
|
|
recv <- hdr "Recv-Date" parseISO8601Val
|
|
|
return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
|
|
@@ -249,3 +314,27 @@ parseMetadata = do
|
|
|
skipHorizontalSpace
|
|
|
r <- parseLineResponse
|
|
|
return (a, r)
|
|
|
+
|
|
|
+getDeliver :: (DeliverData -> a) -> Metadata -> Maybe a
|
|
|
+getDeliver f Metadata{_actionData=act} = case act of
|
|
|
+ Deliver dt -> Just $ f dt
|
|
|
+ Delete dt -> Just $ f dt
|
|
|
+ _ -> Nothing
|
|
|
+
|
|
|
+getTo :: Metadata -> [Address]
|
|
|
+getTo Metadata{_actionData=act} = case act of
|
|
|
+ Deliver dt -> rcptTo dt
|
|
|
+ Delete dt -> rcptTo dt
|
|
|
+ WillHandle dt -> hdl dt
|
|
|
+ Verify dt -> hdl dt
|
|
|
+ Fetch (FetchData _ _ dt) -> hdl dt
|
|
|
+ where
|
|
|
+ hdl (HandleAddress a) = [a]
|
|
|
+ hdl _ = []
|
|
|
+
|
|
|
+getHandle :: Metadata -> Maybe HandleData
|
|
|
+getHandle Metadata{_actionData=act} = case act of
|
|
|
+ WillHandle dt -> Just dt
|
|
|
+ Verify dt -> Just dt
|
|
|
+ Fetch (FetchData _ _ dt) -> Just dt
|
|
|
+ _ -> Nothing
|