FTCH and DELT support

src/Walrus/Backend/Metadata.hs

@@ -20,8 +20,6 @@ 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
@@ -42,6 +40,8 @@ data BackendAction =
   -- | 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)
 
@@ -50,7 +50,9 @@ 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, _mtargetResc :: Maybe Address, _mtargetFailure :: Maybe (Address, Response)
+                                    _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.
@@ -61,7 +63,8 @@ data Metadata = Metadata {_clientId :: ClientIdentity, _auth :: Maybe ByteString
 data ActionData = Deliver DeliverData |
                   WillHandle HandleData |
                   Verify HandleData |
-                  Fetch FetchData |
+                  FetchResc FetchRescData |
+                  FetchHdr FetchHdrData |
                   Delete DeliverData deriving (Show, Ord, Eq)
 
 data DeliverData = DeliverData {clientName :: ByteString,
@@ -71,11 +74,26 @@ data DeliverData = DeliverData {clientName :: ByteString,
 data HandleData = HandleAddress Address |
                   HandleResponse (Address, Response) |
                   HandleOk deriving (Show, Ord, Eq)
-data FetchData = FetchData
+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)
 
@@ -84,7 +102,9 @@ makeLenses ''MaybeMetadata
 makeLenses ''Metadata
 
 instance Default MaybeMetadata where
-  def = MaybeMetadata Nothing Nothing Nothing [] [] Nothing Nothing Mime.B7BitEncoding False Nothing [] Nothing Nothing Nothing
+  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
@@ -103,10 +123,13 @@ strictMetadata m = do
   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 -> m' <$> Fetch <$> getFetchData
+    FETCH -> if headers
+             then m' <$> FetchHdr <$> getFetchHdr
+             else m' <$> FetchResc <$> getFetchResc
     WILLHANDLE -> m' <$> WillHandle <$> getHandleData
     VERIFY -> m' <$> Verify <$> getHandleData
   where
@@ -128,16 +151,26 @@ strictMetadata m = do
         [] -> case rfail of
           (f:_) -> return $ HandleResponse f
           [] -> return $ HandleOk
-    getFetchData :: Maybe FetchData
-    getFetchData = do
+    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 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
+      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
@@ -165,7 +198,8 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
       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
+      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
@@ -179,17 +213,33 @@ renderMetadata m = BS.concat $ serializeDt ++ serializeMain ++ ["\r\n"]
         "Client-Name: ", s cnm, "\r\n",
         "Return-Path: ", s . normalAccountName $ rfm, "\r\n",
         "Body-Encoding: ", show enc, "\r\n",
-        "SMTP-UTF8: ", if utf then "Yes" else "No", "\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 = []
-    serializeFetch (FetchData cnm rfm hnd) =
+    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"] ++
+       "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
@@ -247,6 +297,21 @@ parseMetadata = do
       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
@@ -327,7 +392,8 @@ getTo Metadata{_actionData=act} = case act of
   Delete dt -> rcptTo dt
   WillHandle dt -> hdl dt
   Verify dt -> hdl dt
-  Fetch (FetchData _ _ dt) -> hdl dt
+  FetchResc (FetchRescData _ _ _ _ dt) -> hdl dt
+  FetchHdr (FetchHdrData _ _ _ _ dt) -> hdl dt
   where
     hdl (HandleAddress a) = [a]
     hdl _ = []
@@ -336,5 +402,6 @@ getHandle :: Metadata -> Maybe HandleData
 getHandle Metadata{_actionData=act} = case act of
   WillHandle dt -> Just dt
   Verify dt -> Just dt
-  Fetch (FetchData _ _ dt) -> Just dt
+  FetchResc (FetchRescData _ _ _ _ dt) -> Just dt
+  FetchHdr (FetchHdrData _ _ _ _ dt) -> Just dt
   _ -> Nothing