diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 38916aa31..5c9a475cf 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 0fe36d41f..56fd9be32 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/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" diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 4c1291a21..6fd8aa148 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 6a7edd36f..9147f1f20 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/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 diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 9ea6f0496..01d6f9a80 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/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)) diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 429973c7b..0c5d1ecb0 100644 --- a/tests/XFTPServerTests.hs +++ b/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))