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

@@ -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

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

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,
   )

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

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