Adequated to new protocol specification (RCPT takes only accounts)

src/Walrus/Backend/Metadata.hs

@@ -6,8 +6,10 @@ module Walrus.Backend.Metadata where
 import Data.ByteString (ByteString)
 import Data.Time.Clock (UTCTime)
 
-import Data.SMTP.Address
+import Data.SMTP.Address (Address)
+import qualified Data.SMTP.Address as Add
 import Data.SMTP.Account
+--import qualified Data.SMTP.URI as URI
 import qualified Data.SMTP.Mime as Mime
 import Data.SMTP.Response
 import Text.StringConvert
@@ -36,9 +38,8 @@ data BackendAction =
   -- | Verifies if accounts exist as in the Data.SMTP.VRFY command
   VERIFY |
   -- | Fetch a resource
-  FETCH |
-  -- | Delete a resource
-  DELETE deriving (Show, Read, Eq, Ord, Bounded, Enum)
+  FETCH
+  deriving (Show, Read, Eq, Ord, Bounded, Enum)
 
 data FtchQuery = FtchQueryAll deriving (Eq, Ord, Show, Read)
 
@@ -47,10 +48,10 @@ data ClientIdentity = ClientIdentity {_clientIp :: IP, _clientPort :: Int} deriv
 
 -- | 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)],
+                                    _mmailFrom :: Maybe Account, _mrcptTo :: [Account], _mrcptFailed :: [(Account, 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),
+                                    _mdataSize :: Maybe Int, _mtargetResc :: Maybe Address, _mtargetFailure :: Maybe Response,
                                     _mftchRecursive :: Bool, _mftchHeaders :: Bool, _mftchQuery :: FtchQuery,
                                     _mftchOffset :: Int, _mftchSize :: Maybe Int
                                    } deriving (Show, Ord, Eq)
@@ -61,19 +62,19 @@ data Metadata = Metadata {_clientId :: ClientIdentity, _auth :: Maybe ByteString
                           _dataSize :: Int, _actionData :: ActionData} deriving (Show, Ord, Eq)
 
 data ActionData = Deliver DeliverData |
-                  WillHandle HandleData |
-                  Verify HandleData |
+                  WillHandle AccountData |
+                  Verify AccountData |
                   FetchResc FetchRescData |
-                  FetchHdr FetchHdrData |
-                  Delete DeliverData deriving (Show, Ord, Eq)
+                  FetchHdr FetchHdrData
+                deriving (Show, Ord, Eq)
 
 data DeliverData = DeliverData {clientName :: ByteString,
-                                mailFrom :: Account, rcptTo :: [Address], rcptFailed :: [(Address, Response)],
+                                mailFrom :: Account, rcptTo :: [Account], rcptFailed :: [(Account, Response)],
                                 bodyEnc :: Mime.BodyEncoding, smtpUtf8 :: Bool
                                }  deriving (Show, Ord, Eq)
-data HandleData = HandleAddress Address |
-                  HandleResponse (Address, Response) |
-                  HandleOk deriving (Show, Ord, Eq)
+data AccountData = AccountRequest Account |
+                   AccountResponse (Account, Response) |
+                   AccountOk deriving (Show, Ord, Eq)
 
 {- |
 Data for fetching resource:
@@ -82,7 +83,8 @@ Data for fetching resource:
 FetchRescData clientName account offset size target_or_error
 @
 -}
-data FetchRescData = FetchRescData
+data FetchRescData =
+  FetchRescData
   -- Client name
   ByteString
   -- From account
@@ -91,8 +93,11 @@ data FetchRescData = FetchRescData
   Int
   -- Size
   Int
-  -- Target or fetch error
-  HandleData deriving (Show, Ord, Eq)
+  -- Target
+  Address
+  -- Fetch result
+  (Maybe Response)
+  deriving (Show, Ord, Eq)
 {- |
 Data for fetching headers:
 
@@ -100,7 +105,8 @@ Data for fetching headers:
 FetchHdrData clientName account onlyHeaders query
 @
 -}
-data FetchHdrData = FetchHdrData
+data FetchHdrData =
+  FetchHdrData
   -- Client name
   ByteString
   -- From account
@@ -109,8 +115,11 @@ data FetchHdrData = FetchHdrData
   Bool
   -- Query
   FtchQuery
-  -- Target or fetch error
-  HandleData deriving (Show, Ord, Eq)
+  -- Target
+  Address
+  -- Fetch result
+  (Maybe Response)
+  deriving (Show, Ord, Eq)
 
 makeLenses ''ClientIdentity
 makeLenses ''MaybeMetadata
@@ -141,12 +150,11 @@ strictMetadata m = do
       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
+    WILLHANDLE -> m' <$> WillHandle <$> getAccountData
+    VERIFY -> m' <$> Verify <$> getAccountData
   where
     getDeliverData :: Maybe DeliverData
     getDeliverData = do
@@ -157,34 +165,33 @@ strictMetadata m = do
           enc = m^.mbodyEnc
           utf = m^.msmtpUtf8
       return $ DeliverData cnm rfm rto rfail enc utf
-    getHandleData :: Maybe HandleData
-    getHandleData = let
+    getAccountData :: Maybe AccountData
+    getAccountData = let
       rto = m^.mrcptTo
       rfail = m^.mrcptFailed
       in case rto of
-        (t:_) -> return $ HandleAddress t
+        (t:_) -> return $ AccountRequest t
         [] -> case rfail of
-          (f:_) -> return $ HandleResponse f
-          [] -> return $ HandleOk
+          (f:_) -> return $ AccountResponse f
+          [] -> return $ AccountOk
     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
+      trg <- m^.mtargetResc
+      let resp = m^.mtargetFailure
+      return $ FetchRescData cnm rfm ofst sz trg resp
     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
+      trg <- m^.mtargetResc
+      let resp = m^.mtargetFailure
+      return $ FetchHdrData cnm rfm r q trg resp
       
 
 -- | Converts the metadata to text on the format required by walrus backends.
@@ -210,7 +217,6 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
       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
@@ -222,8 +228,8 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
       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
+      toStr = List.concatMap (\x -> ["To: ", fullAccount x, "\r\n"]) rto
+      failStr = List.concatMap (\(a, r) -> ["Failed: ", fullAccount a, "; ", renderLineResponse r, "\r\n"]) rfail
       h = [
         "Client-Name: ", s cnm, "\r\n",
         "Return-Path: ", s . normalize $ rfm, "\r\n",
@@ -231,23 +237,29 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\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) =
+    serializeHandle (AccountRequest a) = ["Target: ", s . show $ a, "\r\n"]
+    serializeHandle (AccountResponse (a, r)) = ["Failed: ", fullAccount a, renderLineResponse r, "\r\n"]
+    serializeHandle AccountOk = []
+    serializeFetchResc (FetchRescData cnm rfm ofst sz trg resp) =
       ["Client-Name: ", s cnm, "\r\n",
        "Return-Path: ", s . normalize $ 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) =
+       "Block-Size: ", s . show $ sz, "\r\n",
+       "Target: ", s . show $ trg, "\r\n"] ++
+      case resp of
+        Nothing -> []
+        Just r -> ["Failure: ", renderLineResponse r, "\r\n"]
+    serializeFetchHdr (FetchHdrData cnm rfm r q trg resp) =
       ["Client-Name: ", s cnm, "\r\n",
        "Return-Path: ", s . normalize $ rfm, "\r\n",
        "Headers: Yes\r\n",
        "Recursive: ", serialBool r, "\r\n",
-       "Query: ", serializeFtchQuery q, "\r\n"] ++
-      serializeHandle hnd
+       "Query: ", serializeFtchQuery q, "\r\n",
+       "Target: ", s . show $ trg, "\r\n"] ++
+      case resp of
+        Nothing -> []
+        Just rs -> ["Failure: ", renderLineResponse rs, "\r\n"]
     serialBool b = if b then "Yes" else "No"
 
 serializeFtchQuery :: FtchQuery -> ByteString
@@ -288,15 +300,21 @@ parseMetadata = do
         frm <- hdr "Return-Path" parseAccount
         return $ \(m, ip, p) -> (set mmailFrom (Just frm) m, ip, p),
       do
-        rtp <- hdr "To" parseAddress
+        rtp <- hdr "To" parseAccount
         return $ \(m, ip, p) -> let
           crtp = m^.mrcptTo
-          in (set mrcptTo (rtp:crtp) $ set mtargetResc (Just rtp) m, ip, p),
+          in (set mrcptTo (rtp:crtp) m, ip, p),
       do
-        rfl <- hdr "Failed" parseAddressingReason
+        resc <- hdr "Target" Add.parseAddress
+        return $ \(m, ip, p) -> (set mtargetResc (Just resc) m, ip, p),
+      do
+        rfl <- hdr "Failed" parseAccountReason
         return $ \(m, ip, p) -> let
           fld = m^.mrcptFailed
-          in (set mrcptFailed (rfl:fld) $ set mtargetFailure (Just rfl) m, ip, p),
+          in (set mrcptFailed (rfl:fld) m, ip, p),
+      do
+        e <- hdr "Failure" parseLineResponse
+        return $ \(m, ip, p) -> (set mtargetFailure (Just e) m, ip, p),
       do
         recv <- hdr "Recv-Date" parseISO8601Val
         return $ \(m, ip, p) -> (set mrecvDate (Just recv) m, ip, p),
@@ -386,37 +404,33 @@ parseMetadata = do
       A.stringCI "YES" *> return True,
       A.stringCI "NO" *> return False
       ]
-    parseAddressingReason :: Parser (Address, Response)
-    parseAddressingReason = do
-      a <- parseMetadataAddress
+    parseAccountReason :: Parser (Account, Response)
+    parseAccountReason = do
+      a <- parseAccount
       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
+getDeliver :: Metadata -> Maybe DeliverData
+getDeliver Metadata{_actionData=act} = case act of
+  Deliver dt -> Just $ dt
   _ -> Nothing
 
-getTo :: Metadata -> [Address]
+getTo :: Metadata -> [Account]
 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
+  FetchResc (FetchRescData _ _ _ _ dt _) -> [Add.account dt]
+  FetchHdr (FetchHdrData _ _ _ _ dt _) -> [Add.account dt]
   where
-    hdl (HandleAddress a) = [a]
+    hdl (AccountRequest a) = [a]
     hdl _ = []
 
-getHandle :: Metadata -> Maybe HandleData
+getHandle :: Metadata -> Maybe AccountData
 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