xftp: FDEL and FACK commands (#648)

* xftp: FDEL and FACK commands

* correction

* more tests

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

src/Simplex/FileTransfer/Client.hs

@@ -131,16 +131,12 @@ createXFTPChunk ::
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
 createXFTPChunk c spKey file rsps =
   sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
-    -- TODO check that body is empty
-    (FRSndIds sId rIds, _body) -> pure (sId, rIds)
+    (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
 uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO ()
 uploadXFTPChunk c spKey fId chunkSpec =
-  sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= \case
-    -- TODO check that body is empty
-    (FROk, _body) -> pure ()
-    (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+  sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse
 
 downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO ()
 downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
@@ -157,6 +153,23 @@ downloadXFTPChunk c rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath} = do
       _ -> throwError $ PCEResponseError NO_FILE
     (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
 
+deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO ()
+deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse
+
+ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO ()
+ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse
+
+okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO ()
+okResponse = \case
+  (FROk, body) -> noFile body ()
+  (r, _) -> throwError . PCEUnexpectedResponse $ bshow r
+
+-- TODO this currently does not check anything because response size is not set and bodyPart is always Just
+noFile :: HTTP2Body -> a -> ExceptT XFTPClientError IO a
+noFile HTTP2Body {bodyPart} a = case bodyPart of
+  Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE
+  _ -> pure a
+
 -- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
 -- FDEL :: FileCommand Sender
 -- FACK :: FileCommand Recipient

src/Simplex/FileTransfer/Protocol.hs

@@ -317,6 +317,8 @@ data XFTPErrorType
     NO_FILE
   | -- | unexpected file body
     HAS_FILE
+  | -- | file IO error
+    FILE_IO
   | -- | internal server error
     INTERNAL
   | -- | used internally, never returned by the server (to be removed)
@@ -333,6 +335,7 @@ instance Encoding XFTPErrorType where
     DIGEST -> "DIGEST"
     NO_FILE -> "NO_FILE"
     HAS_FILE -> "HAS_FILE"
+    FILE_IO -> "FILE_IO"
     INTERNAL -> "INTERNAL"
     DUPLICATE_ -> "DUPLICATE_"
 
@@ -346,6 +349,7 @@ instance Encoding XFTPErrorType where
       "DIGEST" -> pure DIGEST
       "NO_FILE" -> pure NO_FILE
       "HAS_FILE" -> pure HAS_FILE
+      "FILE_IO" -> pure FILE_IO
       "INTERNAL" -> pure INTERNAL
       "DUPLICATE_" -> pure DUPLICATE_
       _ -> fail "bad error type"

src/Simplex/FileTransfer/Server.hs

@@ -17,6 +17,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
 import Crypto.Random (getRandomBytes)
+import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Builder (byteString)
 import Data.ByteString.Char8 (ByteString)
@@ -38,7 +39,7 @@ import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey)
+import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog)
@@ -176,7 +177,7 @@ verifyXFTPTransmission sig_ signed fId cmd =
       atomically $ verify <$> getFile st party fId
       where
         verify = \case
-          Right (fr, k) -> XFTPReqCmd fr cmd `verifyWith` k
+          Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k
           _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
     req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed
 
@@ -193,12 +194,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       forM (L.zip rIds rcps) $ \rcp ->
         ExceptT $ atomically $ addRecipient st sId rcp
     noFile $ either FRErr (const $ FRSndIds sId rIds) r
-  XFTPReqCmd fr (FileCmd _ cmd) -> case cmd of
+  XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
     FADD _rcps -> noFile FROk
     FPUT -> (,Nothing) <$> receiveServerFile fr
-    FDEL -> noFile FROk
+    FDEL -> (,Nothing) <$> deleteServerFile fr
     FGET rDhKey -> sendServerFile fr rDhKey
-    FACK -> noFile FROk
+    FACK -> (,Nothing) <$> ackFileReception fId fr
     -- it should never get to the options below, they are passed in other constructors of XFTPRequest
     FNEW _ _ -> noFile $ FRErr INTERNAL
     PING -> noFile FRPong
@@ -217,7 +218,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         liftIO $
           runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case
             Right () -> atomically $ writeTVar filePath (Just fPath) $> FROk
-            Left e -> whenM (doesFileExist fPath) (removeFile fPath) $> FRErr e
+            Left e -> (whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError) $> FRErr e
 
     sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile)
     sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rDhKey = do
@@ -231,6 +232,25 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
             _ -> (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
 
+    deleteServerFile :: FileRec -> M FileResponse
+    deleteServerFile FileRec {senderId, filePath} = do
+      r <- runExceptT $ do
+        path <- readTVarIO filePath
+        ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p))
+        st <- asks store
+        void $ atomically $ deleteFile st senderId
+        pure FROk
+      either (pure . FRErr) pure r
+
+    logFileError :: SomeException -> IO ()
+    logFileError e = logError $ "Error deleting file: " <> tshow e
+
+    ackFileReception :: RecipientId -> FileRec -> M FileResponse
+    ackFileReception rId fr = do
+      st <- asks store
+      atomically $ deleteRecipient st rId fr
+      pure FROk
+
 randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString
 randomId n = do
   gVar <- asks idsDrg

src/Simplex/FileTransfer/Server/Env.hs

@@ -14,7 +14,7 @@ import Data.Time.Clock (getCurrentTime)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo)
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId)
 import Simplex.FileTransfer.Server.Stats
 import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
@@ -63,5 +63,5 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, caCertificateFile, certi
 
 data XFTPRequest
   = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey)
-  | XFTPReqCmd FileRec FileCmd
+  | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing

src/Simplex/FileTransfer/Server/Store.hs

@@ -11,6 +11,7 @@ module Simplex.FileTransfer.Server.Store
     setFilePath,
     addRecipient,
     deleteFile,
+    deleteRecipient,
     getFile,
     ackFile,
   )
@@ -84,6 +85,11 @@ deleteFile FileStore {files, recipients} senderId = do
       pure $ Right ()
     _ -> pure $ Left AUTH
 
+deleteRecipient :: FileStore -> RecipientId -> FileRec -> STM ()
+deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do
+  TM.delete rId recipients
+  modifyTVar' recipientIds $ S.delete rId
+
 getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey))
 getFile st party fId = case party of
   SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f))

tests/XFTPServerTests.hs

@@ -1,17 +1,19 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
 
 module XFTPServerTests where
 
 import AgentTests.FunctionalAPITests (runRight_)
+import Control.Exception (SomeException)
 import Control.Monad.Except
 import Crypto.Random (getRandomBytes)
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.List (isInfixOf)
 import Simplex.FileTransfer.Client
 import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
@@ -30,8 +32,12 @@ xftpServerTests =
     . after_ (removeDirectoryRecursive xftpServerFiles)
     $ do
       describe "XFTP file chunk delivery" $ do
-        it "should create, upload and receive file chunk" testFileChunkDelivery
+        it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery
         it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2
+        it "should delete file chunk (1 client)" testFileChunkDelete
+        it "should delete file chunk (2 clients)" testFileChunkDelete2
+        it "should acknowledge file chunk reception (1 client)" testFileChunkAck
+        it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
 
 chSize :: Num n => n
 chSize = 128 * 1024
@@ -72,3 +78,56 @@ runTestFileChunkDelivery s r = do
     `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST))
   downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
   liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+
+testFileChunkDelete :: Expectation
+testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
+
+testFileChunkDelete2 :: Expectation
+testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
+
+runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
+runTestFileChunkDelete s r = do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey]
+  uploadXFTPChunk s spKey sId chunkSpec
+
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+  deleteXFTPChunk s spKey sId
+  liftIO $ readChunk sId
+    `shouldThrow` \(e :: SomeException) -> "openBinaryFile: does not exist" `isInfixOf` show e
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+  deleteXFTPChunk s spKey sId
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+
+testFileChunkAck :: Expectation
+testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
+
+testFileChunkAck2 :: Expectation
+testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
+
+runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
+runTestFileChunkAck s r =  do
+  (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
+  bytes <- liftIO $ createTestChunk testChunkPath
+  digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
+  let file = FileInfo {sndKey, size = chSize, digest}
+      chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
+  (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey]
+  uploadXFTPChunk s spKey sId chunkSpec
+
+  downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
+  liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
+  ackXFTPChunk r rpKey rId
+  liftIO $ readChunk sId `shouldReturn` bytes
+  downloadXFTPChunk r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
+  ackXFTPChunk r rpKey rId
+    `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))