123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407 |
- {-# 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 Text.StringConvert
- import Data.Time.ISO8601
- import Data.IP
- import Data.Default.Class
- 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
- -- | All the actions that walrus may request from a backend
- data BackendAction =
- -- | Recieve new resource
- DELIVER |
- -- | Verify if a backend will handle the rcpt to addresses
- WILLHANDLE |
- -- | Verifies if accounts exist as in the SMTP VRFY command
- VERIFY |
- -- | Fetch a resource
- FETCH |
- -- | Delete a resource
- DELETE deriving (Show, Read, Eq, Ord, Bounded, Enum)
- data FtchQuery = FtchQueryAll deriving (Eq, Ord, Show, Read)
- -- | The network data of a client (IP and port)
- data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriving (Show, Read, Ord, Eq)
- -- | A possibly empty version of Metadata for iterative filling. Convert with strictMetadata.
- 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, _mtargetResc :: Maybe Address, _mtargetFailure :: Maybe (Address, Response),
- _mftchRecursive :: Bool, _mftchHeaders :: Bool, _mftchQuery :: FtchQuery,
- _mftchOffset :: Int, _mftchSize :: Maybe Int
- } deriving (Show, Ord, Eq)
- -- | All the data of a backend metadata, as the walrus specification.
- 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 |
- FetchResc FetchRescData |
- FetchHdr FetchHdrData |
- 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 FetchRescData = FetchRescData
- -- | Client name
- ByteString
- -- | From account
- Account
- -- | Offset
- Int
- -- | Size
- Int
- -- | Target or fetch error
- HandleData deriving (Show, Ord, Eq)
- data FetchHdrData = FetchHdrData
- -- | Client name
- ByteString
- -- | From account
- Account
- -- | Only headers
- Bool
- -- | Query
- FtchQuery
- -- | 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 Nothing Nothing
- False False FtchQueryAll 0 Nothing
- -- | Creates an empty metadata with just the client identity
- metadataForClient :: IP -> Int -> MaybeMetadata
- metadataForClient c p = def & mclientId .~ Just (ClientIdentity c p)
- -- | Blanks the data as necessary for the RSET SMTP command
- resetMetadata :: MaybeMetadata -> MaybeMetadata
- resetMetadata d = def & mclientId .~ d^.mclientId & mclientName .~ d^.mclientName
- -- | Converts a fully filled MaybeMetadata into its strict version
- strictMetadata :: MaybeMetadata -> Maybe Metadata
- strictMetadata m = do
- act <- m^.maction
- cid <- m^.mclientId
- let usr = m^.mauth
- rcv <- m^.mrecvDate
- let unrq = m^.munrecognized
- sz <- m^.mdataSize
- let m' = Metadata cid usr rcv unrq sz
- headers = m^.mftchHeaders
- case act of
- DELIVER -> m' <$> Deliver <$> getDeliverData
- DELETE -> m' <$> Delete <$> getDeliverData
- FETCH -> if headers
- then m' <$> FetchHdr <$> getFetchHdr
- else m' <$> FetchResc <$> getFetchResc
- 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
- getFetchResc :: Maybe FetchRescData
- getFetchResc = do
- cnm <- m^.mclientName
- rfm <- m^.mmailFrom
- let ofst = m^.mftchOffset
- sz <- m^.mftchSize
- return $ FetchRescData cnm rfm ofst sz getFetchHandle
- getFetchHdr :: Maybe FetchHdrData
- getFetchHdr = do
- cnm <- m^.mclientName
- rfm <- m^.mmailFrom
- let r = m^.mftchRecursive
- q = m^.mftchQuery
- return $ FetchHdrData cnm rfm r q getFetchHandle
- getFetchHandle = case m^.mtargetResc of
- Just t -> HandleAddress t
- Nothing -> case m^.mtargetFailure of
- Just f -> HandleResponse f
- Nothing -> HandleOk
-
- -- | Converts the metadata to text on the format required by walrus backends.
- renderMetadata :: Metadata -> ByteString
- renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
- where
- serializeMain :: [ByteString]
- serializeMain = let
- cid = m^.clientId
- usr = m^.auth
- rcv = m^.recvDate
- sz = m^.dataSize
- usrStr = case usr of
- Nothing -> []
- Just u -> ["Auth-User: ", u, "\r\n"]
- unrec = m^.unrecognized
- h = [
- "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
- FetchResc dt -> "Action: FETCH\r\n" : serializeFetchResc dt
- FetchHdr dt -> "Action: FETCH\r\n": serializeFetchHdr 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",
- "Body-Encoding: ", show enc, "\r\n",
- "SMTP-UTF8: ", serialBool utf, "\r\n"
- ] :: [String]
- 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 = []
- serializeFetchResc (FetchRescData cnm rfm ofst sz hnd) =
- ["Client-Name: ", s cnm, "\r\n",
- "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
- "Headers: No\r\n",
- "Offset: ", s . show $ ofst, "\r\n",
- "Block-Size: ", s . show $ sz, "\r\n"] ++
- serializeHandle hnd
- serializeFetchHdr (FetchHdrData cnm rfm r q hnd) =
- ["Client-Name: ", s cnm, "\r\n",
- "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
- "Headers: Yes\r\n",
- "Recursive: ", serialBool r, "\r\n",
- "Query: ", serializeFtchQuery q, "\r\n"] ++
- serializeHandle hnd
- serialBool b = if b then "Yes" else "No"
- serializeFtchQuery :: FtchQuery -> ByteString
- serializeFtchQuery _ = "()"
- parseFtchQuery :: A.Parser FtchQuery
- parseFtchQuery = A.string "()" >> return FtchQueryAll
- -- | Reads a metadata from a textual representation on the format expected by the walrus backends
- 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 sm -> return sm
- Nothing -> fail "missing required fields"
- where
- parseField :: Parser ((MaybeMetadata, Maybe IP, Maybe Int) -> (MaybeMetadata, Maybe IP, Maybe Int))
- parseField = 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) $ 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) $ set mtargetFailure (Just rfl) 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" A.takeByteString
- 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
- off <- hdr "Offset" A.decimal
- return $ \(m, ip, p) -> (m &mftchOffset.~off, ip, p),
- do
- sz <- hdr "Block-Size" A.decimal
- return $ \(m, ip, p) -> (m &mftchSize.~Just sz, ip, p),
- do
- h <- hdr "Headers" parseMetadataBool
- return $ \(m, ip, p) -> (m &mftchHeaders.~h, ip, p),
- do
- r <- hdr "Recursive" parseMetadataBool
- return $ \(m, ip, p) -> (m &mftchRecursive.~r, ip, p),
- do
- q <- hdr "Query" parseFtchQuery
- return $ \(m, ip, p) -> (m &mftchQuery.~q, 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 _ -> fail $ "failed parsing value of " ++ s pt
- 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 . s $ v of
- Nothing -> fail "failed parsing value"
- Just i -> return i
- parseISO8601Val = do
- v <- A.takeTill A.isSpace
- case parseISO8601 . s $ v of
- Nothing -> fail "failed parsing ISO8601 date"
- Just t -> return t
- parseMetadataBool :: Parser Bool
- parseMetadataBool = 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)
- 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
- FetchResc (FetchRescData _ _ _ _ dt) -> hdl dt
- FetchHdr (FetchHdrData _ _ _ _ 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
- FetchResc (FetchRescData _ _ _ _ dt) -> Just dt
- FetchHdr (FetchHdrData _ _ _ _ dt) -> Just dt
- _ -> Nothing
|