From 37b3ad027e0de1c8a61001df1ac3eb4e4acf08e5 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 7 Apr 2026 12:59:43 +0000 Subject: [PATCH] refactor: clean up per good-code review - Remove internal helpers from Postgres.hs export list (withDB, withDB', handleDuplicate, assertUpdated, withLog are not imported externally) - Replace local isNothing_ with Data.Maybe.isNothing in Env.hs - Consolidate duplicate/unused imports in XFTPStoreTests.hs - Add file_path IS NULL and status guards to STM setFilePath, matching the Postgres implementation semantics --- src/Simplex/FileTransfer/Server/Env.hs | 6 +- src/Simplex/FileTransfer/Server/Store.hs | 12 +- .../FileTransfer/Server/Store/Postgres.hs | 5 - tests/CoreTests/XFTPStoreTests.hs | 11 +- tests/XFTPServerTests.hs | 113 ++++++++++++------ 5 files changed, 91 insertions(+), 56 deletions(-) diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 23450384f..3a2e6d785 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -41,6 +41,7 @@ import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation) #if defined(dbServerPostgres) import Data.Functor (($>)) +import Data.Maybe (isNothing) import Simplex.FileTransfer.Server.Store.Postgres (PostgresFileStore, importFileStore, exportFileStore) import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts) import Simplex.Messaging.Server.CLI (iniDBOptions, settingIsOn) @@ -190,14 +191,11 @@ checkFileStoreMode ini storeType storeLogFilePath = case storeType of "database" -> do storeLogExists <- doesFileExist storeLogFilePath let dbStoreLogOn = settingIsOn "STORE_LOG" "db_store_log" ini - when (storeLogExists && isNothing_ dbStoreLogOn) $ do + when (storeLogExists && isNothing dbStoreLogOn) $ do putStrLn $ "Error: store log file " <> storeLogFilePath <> " exists but store_files is `database`." putStrLn "Use `file-server database import` to migrate, or set `db_store_log: on`." exitFailure _ -> pure () - where - isNothing_ Nothing = True - isNothing_ _ = False #else checkFileStoreMode _ _ _ = pure () #endif diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 008a959f4..ae9042160 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -97,9 +97,15 @@ instance FileStoreClass STMFileStore where pure $ Right () setFilePath st sId fPath = atomically $ - withSTMFile st sId $ \FileRec {filePath} -> do - writeTVar filePath (Just fPath) - pure $ Right () + withSTMFile st sId $ \FileRec {filePath, fileStatus} -> do + readTVar filePath >>= \case + Just _ -> pure $ Left AUTH + Nothing -> + readTVar fileStatus >>= \case + EntityActive -> do + writeTVar filePath (Just fPath) + pure $ Right () + _ -> pure $ Left AUTH addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withSTMFile st senderId $ \FileRec {recipientIds} -> do diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index d883eb4a7..ceca5c89f 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -9,11 +9,6 @@ module Simplex.FileTransfer.Server.Store.Postgres ( PostgresFileStore (..), - withDB, - withDB', - handleDuplicate, - assertUpdated, - withLog, importFileStore, exportFileStore, ) diff --git a/tests/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index a70ac0812..2d0ff11f7 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -6,22 +6,17 @@ module CoreTests.XFTPStoreTests (xftpStoreTests, xftpMigrationTests) where import Control.Monad -import qualified Data.ByteString.Char8 as B import Data.Word (Word32) -import qualified Data.Set as S import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..)) import Simplex.FileTransfer.Server.Store -import Simplex.FileTransfer.Server.Store.Postgres (PostgresFileStore) -import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg) -import Simplex.FileTransfer.Server.StoreLog +import Simplex.FileTransfer.Server.Store.Postgres (PostgresFileStore, importFileStore, exportFileStore) +import Simplex.FileTransfer.Server.StoreLog (closeStoreLog, readWriteFileStore, writeFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BlockingInfo (..), BlockingReason (..), EntityId (..)) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) -import Simplex.Messaging.SystemTime (RoundedSystemTime (..)) -import Simplex.FileTransfer.Server.Store.Postgres (importFileStore, exportFileStore) -import Simplex.FileTransfer.Server.StoreLog (readWriteFileStore, writeFileStore) import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) +import Simplex.Messaging.SystemTime (RoundedSystemTime (..)) import System.Directory (doesFileExist, removeFile) import Test.Hspec hiding (fit, it) import UnliftIO.STM diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index d4a2578cc..f6f2c718a 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -56,7 +56,17 @@ xftpServerTests :: Spec xftpServerTests = before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do describe "XFTP file chunk delivery" $ do + it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery + it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2 + it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients + 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 + it "should not allow chunks of wrong size" testWrongChunkSize + it "should expire chunks after set interval" testFileChunkExpiration it "should disconnect inactive clients" testInactiveClientExpiration + it "should not allow uploading chunks after specified storage quota" testFileStorageQuota it "should store file records to log and restore them after server restart" testFileLog describe "XFTP basic auth" $ do it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False @@ -99,9 +109,30 @@ xftpFileTests = do it "should expire chunks after set interval" $ \(withSrv :: XFTPTestBracket) -> withSrv (\c -> c {fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}) $ testXFTPClient $ \c -> runRight_ $ runTestFileChunkExpiration c + it "should disconnect inactive clients" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}) $ + runRight_ runTestInactiveClientExpiration it "should not allow uploading chunks after specified storage quota" $ \(withSrv :: XFTPTestBracket) -> withSrv (\c -> c {fileSizeQuota = Just $ chSize * 2}) $ testXFTPClient $ \c -> runRight_ $ runTestFileStorageQuota c + describe "XFTP basic auth" $ do + it "prohibited without basic auth" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $ + testXFTPClient $ runTestFileBasicAuth Nothing False + it "prohibited when auth is incorrect" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $ + testXFTPClient $ runTestFileBasicAuth (Just "wrong") False + it "prohibited when FNEW disabled" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {allowNewFiles = False, newFileBasicAuth = Just "pwd"}) $ + testXFTPClient $ runTestFileBasicAuth (Just "pwd") False + it "allowed with correct basic auth" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Just "pwd"}) $ + testXFTPClient $ runTestFileBasicAuth (Just "pwd") True + it "allowed with auth on server without auth" $ \(withSrv :: XFTPTestBracket) -> + withSrv (\c -> c {allowNewFiles = True, newFileBasicAuth = Nothing}) $ + testXFTPClient $ runTestFileBasicAuth (Just "any") True + it "should not change content for uploaded and committed files" $ \(withSrv :: XFTPTestBracket) -> + withSrv id $ testXFTPClient runTestFileSkipCommitted chSize :: Integral a => a chSize = kb 128 @@ -266,7 +297,13 @@ runTestFileChunkExpiration c = do `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) testInactiveClientExpiration :: Expectation -testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do +testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration = shortInactiveExpiration} $ \_ -> + runRight_ runTestInactiveClientExpiration + where + shortInactiveExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1} + +runTestInactiveClientExpiration :: ExceptT XFTPClientError IO () +runTestInactiveClientExpiration = do disconnected <- newEmptyTMVarIO ts <- liftIO getCurrentTime c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ()) @@ -278,8 +315,6 @@ testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveC liftIO $ do threadDelay 3000000 atomically (tryTakeTMVar disconnected) `shouldReturn` Just () - where - inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1} testFileStorageQuota :: Expectation testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ @@ -405,43 +440,49 @@ testFileLog = do testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO () testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ - \_ -> testXFTPClient $ \c -> do - g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- createTestChunk testChunkPath - digest <- LC.sha256Hash <$> LB.readFile testChunkPath - let file = FileInfo {sndKey, size = chSize, digest} - chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - runRight_ $ - if success - then do - (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth - uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes - else do - void (createXFTPChunk c spKey file [rcvKey] clntAuth) - `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + \_ -> testXFTPClient $ \c -> runTestFileBasicAuth clntAuth success c + +runTestFileBasicAuth :: Maybe BasicAuth -> Bool -> XFTPClient -> IO () +runTestFileBasicAuth clntAuth success c = do + g <- C.newRandom + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + runRight_ $ + if success + then do + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth + uploadXFTPChunk c spKey sId chunkSpec + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes + else do + void (createXFTPChunk c spKey file [rcvKey] clntAuth) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) testFileSkipCommitted :: IO () testFileSkipCommitted = withXFTPServerCfg testXFTPServerConfig $ - \_ -> testXFTPClient $ \c -> do - g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - bytes <- createTestChunk testChunkPath - digest <- LC.sha256Hash <$> LB.readFile testChunkPath - let file = FileInfo {sndKey, size = chSize, digest} - chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - runRight_ $ do - (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing - uploadXFTPChunk c spKey sId chunkSpec - void . liftIO $ createTestChunk testChunkPath -- trash chunk contents - uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored + \_ -> testXFTPClient runTestFileSkipCommitted + +runTestFileSkipCommitted :: XFTPClient -> IO () +runTestFileSkipCommitted c = do + g <- C.newRandom + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + bytes <- createTestChunk testChunkPath + digest <- LC.sha256Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + runRight_ $ do + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing + uploadXFTPChunk c spKey sId chunkSpec + void . liftIO $ createTestChunk testChunkPath + uploadXFTPChunk c spKey sId chunkSpec + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- SNI and CORS tests