Multiform metadata

src/Walrus/Backend/Metadata.hs

@@ -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