xftp: api to delete snd files internally, cleanup snd files, tests (#719)

src/Simplex/FileTransfer/Agent.hs

@@ -20,6 +20,7 @@ module Simplex.FileTransfer.Agent
     -- Sending files
     sendFileExperimental,
     sendFile,
+    deleteSndFileInternal,
   )
 where
 
@@ -435,7 +436,7 @@ runXFTPSndPrepareWorker c doWork = do
 
 sndWorkerInternalError :: AgentMonad m => AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> String -> m ()
 sndWorkerInternalError c sndFileId sndFileEntityId prefixPath internalErrStr = do
-  forM_ prefixPath (removePath <=< toFSFilePath)
+  forM_ prefixPath $ removePath <=< toFSFilePath
   withStore' c $ \db -> updateSndFileError db sndFileId internalErrStr
   notify c sndFileEntityId $ SFERR $ INTERNAL internalErrStr
 
@@ -490,7 +491,7 @@ runXFTPSndWorker c srv doWork = do
       when complete $ do
         (sndDescr, rcvDescrs) <- sndFileToDescrs sf
         notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
-        forM_ prefixPath (removePath <=< toFSFilePath)
+        forM_ prefixPath $ removePath <=< toFSFilePath
         withStore' c $ \db -> updateSndFileComplete db sndFileId
       where
         addRecipients :: SndFileChunk -> SndFileChunkReplica -> m SndFileChunkReplica
@@ -568,3 +569,12 @@ runXFTPSndWorker c srv doWork = do
         chunkUploaded :: SndFileChunk -> Bool
         chunkUploaded SndFileChunk {replicas} =
           any (\SndFileChunkReplica {replicaStatus} -> replicaStatus == SFRSUploaded) replicas
+
+deleteSndFileInternal :: AgentMonad m => AgentClient -> UserId -> SndFileId -> m ()
+deleteSndFileInternal c userId sndFileEntityId = do
+  SndFile {sndFileId, prefixPath, status} <- withStore c $ \db -> getSndFileByEntityId db userId sndFileEntityId
+  if status == SFSComplete || status == SFSError
+    then do
+      forM_ prefixPath $ removePath <=< toFSFilePath
+      withStore' c (`deleteSndFile'` sndFileId)
+    else withStore' c (`updateSndFileDeleted` sndFileId)

src/Simplex/Messaging/Agent.hs

@@ -84,6 +84,7 @@ module Simplex.Messaging.Agent
     xftpReceiveFile,
     xftpDeleteRcvFile,
     xftpSendFile,
+    xftpDeleteSndFileInternal,
     activateAgent,
     suspendAgent,
     execAgentStoreSQL,
@@ -119,7 +120,7 @@ import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 import qualified Database.SQLite.Simple as DB
-import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteRcvFile, receiveFile, sendFile, startWorkers, toFSFilePath)
+import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteRcvFile, deleteSndFileInternal, receiveFile, sendFile, startWorkers, toFSFilePath)
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Util (removePath)
@@ -351,6 +352,10 @@ xftpDeleteRcvFile c = withAgentEnv c .: deleteRcvFile c
 xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
 xftpSendFile c = withAgentEnv c .:. sendFile c
 
+-- | Delete XFTP snd file internally (deletes work files from file system and db records)
+xftpDeleteSndFileInternal :: AgentErrorMonad m => AgentClient -> UserId -> SndFileId -> m ()
+xftpDeleteSndFileInternal c = withAgentEnv c .: deleteSndFileInternal c
+
 -- TODO rename setAgentForeground
 
 -- | Activate operations
@@ -1598,6 +1603,8 @@ cleanupManager c@AgentClient {subQ} = do
       deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
       deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
       deleteSndFilesExpired `catchError` (notify "" . SFERR)
+      deleteSndFilesDeleted `catchError` (notify "" . SFERR)
+      deleteSndFilesPrefixPaths `catchError` (notify "" . SFERR)
     liftIO $ threadDelay' int
   where
     deleteConns =
@@ -1626,6 +1633,16 @@ cleanupManager c@AgentClient {subQ} = do
       forM_ sndExpired $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
         forM_ p $ removePath <=< toFSFilePath
         withStore' c (`deleteSndFile'` dbId)
+    deleteSndFilesDeleted = do
+      sndDeleted <- withStore' c getCleanupSndFilesDeleted
+      forM_ sndDeleted $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        forM_ p $ removePath <=< toFSFilePath
+        withStore' c (`deleteSndFile'` dbId)
+    deleteSndFilesPrefixPaths = do
+      sndPrefixPaths <- withStore' c getCleanupSndFilesPrefixPaths
+      forM_ sndPrefixPaths $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        removePath =<< toFSFilePath p
+        withStore' c (`updateSndFileNoPrefixPath` dbId)
     notify :: forall e. AEntityI e => EntityId -> ACommand 'Agent e -> ExceptT AgentErrorType m ()
     notify entId cmd = atomically $ writeTBQueue subQ ("", entId, APC (sAEntity @e) cmd)
 

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -153,11 +153,14 @@ module Simplex.Messaging.Agent.Store.SQLite
     -- Snd files
     createSndFile,
     getSndFile,
+    getSndFileByEntityId,
     getNextSndFileToPrepare,
     updateSndFileError,
     updateSndFileStatus,
     updateSndFileEncrypted,
     updateSndFileComplete,
+    updateSndFileNoPrefixPath,
+    updateSndFileDeleted,
     deleteSndFile',
     createSndFileReplica,
     getNextSndChunkToUpload,
@@ -165,6 +168,8 @@ module Simplex.Messaging.Agent.Store.SQLite
     addSndChunkReplicaRecipients,
     updateSndChunkReplicaStatus,
     getPendingSndFilesServers,
+    getCleanupSndFilesPrefixPaths,
+    getCleanupSndFilesDeleted,
     getSndFilesExpired,
 
     -- * utilities
@@ -2103,6 +2108,16 @@ createSndFile db gVar userId numRecipients path prefixPath key nonce =
       "INSERT INTO snd_files (snd_file_entity_id, user_id, num_recipients, key, nonce, path, prefix_path, status) VALUES (?,?,?,?,?,?,?,?)"
       (sndFileEntityId, userId, numRecipients, key, nonce, path, prefixPath, SFSNew)
 
+getSndFileByEntityId :: DB.Connection -> UserId -> SndFileId -> IO (Either StoreError SndFile)
+getSndFileByEntityId db userId sndFileEntityId = runExceptT $ do
+  sndFileId <- ExceptT $ getSndFileIdByEntityId_ db userId sndFileEntityId
+  ExceptT $ getSndFile db sndFileId
+
+getSndFileIdByEntityId_ :: DB.Connection -> UserId -> SndFileId -> IO (Either StoreError DBSndFileId)
+getSndFileIdByEntityId_ db userId sndFileEntityId =
+  firstRow fromOnly SEFileNotFound $
+    DB.query db "SELECT snd_file_id FROM snd_files WHERE user_id = ? AND snd_file_entity_id = ?" (userId, sndFileEntityId)
+
 getSndFile :: DB.Connection -> DBSndFileId -> IO (Either StoreError SndFile)
 getSndFile db sndFileId = runExceptT $ do
   f@SndFile {sndFileEntityId, userId, numRecipients, prefixPath} <- ExceptT getFile
@@ -2219,6 +2234,16 @@ updateSndFileComplete db sndFileId = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE snd_files SET prefix_path = NULL, status = ?, updated_at = ? WHERE snd_file_id = ?" (SFSComplete, updatedAt, sndFileId)
 
+updateSndFileNoPrefixPath :: DB.Connection -> DBSndFileId -> IO ()
+updateSndFileNoPrefixPath db sndFileId = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE snd_files SET prefix_path = NULL, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId)
+
+updateSndFileDeleted :: DB.Connection -> DBSndFileId -> IO ()
+updateSndFileDeleted db sndFileId = do
+  updatedAt <- getCurrentTime
+  DB.execute db "UPDATE snd_files SET deleted = 1, updated_at = ? WHERE snd_file_id = ?" (updatedAt, sndFileId)
+
 deleteSndFile' :: DB.Connection -> DBSndFileId -> IO ()
 deleteSndFile' db sndFileId =
   DB.execute db "DELETE FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)
@@ -2335,6 +2360,27 @@ getPendingSndFilesServers db ttl = do
     toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
     toServer (host, port, keyHash) = XFTPServer host port keyHash
 
+getCleanupSndFilesPrefixPaths :: DB.Connection -> IO [(DBSndFileId, SndFileId, FilePath)]
+getCleanupSndFilesPrefixPaths db =
+  DB.query
+    db
+    [sql|
+      SELECT snd_file_id, snd_file_entity_id, prefix_path
+      FROM snd_files
+      WHERE status IN (?,?) AND prefix_path IS NOT NULL
+    |]
+    (SFSComplete, SFSError)
+
+getCleanupSndFilesDeleted :: DB.Connection -> IO [(DBSndFileId, SndFileId, Maybe FilePath)]
+getCleanupSndFilesDeleted db =
+  DB.query_
+    db
+    [sql|
+      SELECT snd_file_id, snd_file_entity_id, prefix_path
+      FROM snd_files
+      WHERE deleted = 1
+    |]
+
 getSndFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBSndFileId, SndFileId, Maybe FilePath)]
 getSndFilesExpired db ttl = do
   cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime