xftp: restore snd files, expire snd files in agent (#718)

src/Simplex/FileTransfer/Agent.hs

@@ -75,9 +75,10 @@ startWorkers :: AgentMonad m => AgentClient -> Maybe FilePath -> m ()
 startWorkers c workDir = do
   wd <- asks $ xftpWorkDir . xftpAgent
   atomically $ writeTVar wd workDir
-  startFiles
+  startRcvFiles
+  startSndFiles
   where
-    startFiles = do
+    startRcvFiles = do
       rcvFilesTTL <- asks (rcvFilesTTL . config)
       pendingRcvServers <- withStore' c (`getPendingRcvFilesServers` rcvFilesTTL)
       forM_ pendingRcvServers $ \s -> addXFTPRcvWorker c (Just s)
@@ -85,6 +86,12 @@ startWorkers c workDir = do
       -- no need to make an extra query for the check
       -- as the worker will check the store anyway
       addXFTPRcvWorker c Nothing
+    startSndFiles = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      -- start worker for files pending encryption/creation
+      addXFTPSndWorker c Nothing
+      pendingSndServers <- withStore' c (`getPendingSndFilesServers` sndFilesTTL)
+      forM_ pendingSndServers $ \s -> addXFTPSndWorker c (Just s)
 
 closeXFTPAgent :: MonadUnliftIO m => XFTPAgent -> m ()
 closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
@@ -158,11 +165,11 @@ runXFTPRcvWorker c srv doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     -- TODO waitUntilNotSuspended
-    agentOperationBracket c AORcvNetwork waitUntilActive runXftpOperation
+    agentOperationBracket c AORcvNetwork waitUntilActive runXFTPOperation
   where
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    runXftpOperation :: m ()
-    runXftpOperation = do
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
       rcvFilesTTL <- asks (rcvFilesTTL . config)
       nextChunk <- withStore' c $ \db -> getNextRcvChunkToDownload db srv rcvFilesTTL
       case nextChunk of
@@ -229,10 +236,10 @@ runXFTPRcvLocalWorker c doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     -- TODO waitUntilNotSuspended
-    runXftpOperation
+    runXFTPOperation
   where
-    runXftpOperation :: m ()
-    runXftpOperation = do
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
       rcvFilesTTL <- asks (rcvFilesTTL . config)
       nextFile <- withStore' c (`getNextRcvFileToDecrypt` rcvFilesTTL)
       case nextFile of
@@ -350,11 +357,12 @@ runXFTPSndPrepareWorker c doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     -- TODO waitUntilNotSuspended
-    runXftpOperation
+    runXFTPOperation
   where
-    runXftpOperation :: m ()
-    runXftpOperation = do
-      nextFile <- withStore' c getNextSndFileToPrepare
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextFile <- withStore' c (`getNextSndFileToPrepare` sndFilesTTL)
       case nextFile of
         Nothing -> noWorkToDo
         Just f@SndFile {sndFileId, sndFileEntityId, prefixPath} ->
@@ -436,12 +444,13 @@ runXFTPSndWorker c srv doWork = do
   forever $ do
     void . atomically $ readTMVar doWork
     -- TODO waitUntilNotSuspended
-    agentOperationBracket c AOSndNetwork throwWhenInactive runXftpOperation
+    agentOperationBracket c AOSndNetwork throwWhenInactive runXFTPOperation
   where
     noWorkToDo = void . atomically $ tryTakeTMVar doWork
-    runXftpOperation :: m ()
-    runXftpOperation = do
-      nextChunk <- withStore' c $ \db -> getNextSndChunkToUpload db srv
+    runXFTPOperation :: m ()
+    runXFTPOperation = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      nextChunk <- withStore' c $ \db -> getNextSndChunkToUpload db srv sndFilesTTL
       case nextChunk of
         Nothing -> noWorkToDo
         Just SndFileChunk {sndFileId, sndFileEntityId, filePrefixPath, replicas = []} -> sndWorkerInternalError c sndFileId sndFileEntityId (Just filePrefixPath) "chunk has no replicas"

src/Simplex/Messaging/Agent.hs

@@ -97,6 +97,7 @@ where
 
 import Control.Concurrent.STM (stateTVar)
 import Control.Logger.Simple (logError, logInfo, showText)
+import Control.Monad ((<=<))
 import Control.Monad.Except
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Reader
@@ -1596,6 +1597,7 @@ cleanupManager c@AgentClient {subQ} = do
       deleteRcvFilesExpired `catchError` (notify "" . RFERR)
       deleteRcvFilesDeleted `catchError` (notify "" . RFERR)
       deleteRcvFilesTmpPaths `catchError` (notify "" . RFERR)
+      deleteSndFilesExpired `catchError` (notify "" . SFERR)
     liftIO $ threadDelay' int
   where
     deleteConns =
@@ -1618,6 +1620,12 @@ cleanupManager c@AgentClient {subQ} = do
       forM_ rcvTmpPaths $ \(dbId, entId, p) -> flip catchError (notify entId . RFERR) $ do
         removePath =<< toFSFilePath p
         withStore' c (`updateRcvFileNoTmpPath` dbId)
+    deleteSndFilesExpired = do
+      sndFilesTTL <- asks (sndFilesTTL . config)
+      sndExpired <- withStore' c (`getSndFilesExpired` sndFilesTTL)
+      forM_ sndExpired $ \(dbId, entId, p) -> flip catchError (notify entId . SFERR) $ do
+        forM_ p $ removePath <=< toFSFilePath
+        withStore' c (`deleteSndFile'` 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/Env/SQLite.hs

@@ -83,6 +83,7 @@ data AgentConfig = AgentConfig
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
     rcvFilesTTL :: NominalDiffTime,
+    sndFilesTTL :: NominalDiffTime,
     xftpNotifyErrsOnRetry :: Bool,
     xftpMaxRecipientsPerRequest :: Int,
     deleteErrorCount :: Int,
@@ -145,6 +146,7 @@ defaultAgentConfig =
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 30 * 60 * 1000000, -- 30 minutes
       rcvFilesTTL = 2 * nominalDay,
+      sndFilesTTL = nominalDay,
       xftpNotifyErrsOnRetry = True,
       xftpMaxRecipientsPerRequest = 200,
       deleteErrorCount = 10,

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

@@ -158,11 +158,14 @@ module Simplex.Messaging.Agent.Store.SQLite
     updateSndFileStatus,
     updateSndFileEncrypted,
     updateSndFileComplete,
+    deleteSndFile',
     createSndFileReplica,
     getNextSndChunkToUpload,
     updateSndChunkReplicaDelay,
     addSndChunkReplicaRecipients,
     updateSndChunkReplicaStatus,
+    getPendingSndFilesServers,
+    getSndFilesExpired,
 
     -- * utilities
     withConnection,
@@ -2176,8 +2179,9 @@ getChunkReplicaRecipients_ db replicaId =
     |]
     (Only replicaId)
 
-getNextSndFileToPrepare :: DB.Connection -> IO (Maybe SndFile)
-getNextSndFileToPrepare db = do
+getNextSndFileToPrepare :: DB.Connection -> NominalDiffTime -> IO (Maybe SndFile)
+getNextSndFileToPrepare db ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
   fileId_ :: Maybe DBSndFileId <-
     maybeFirstRow fromOnly $
       DB.query
@@ -2185,10 +2189,10 @@ getNextSndFileToPrepare db = do
         [sql|
           SELECT snd_file_id
           FROM snd_files
-          WHERE status IN (?,?,?) AND deleted = 0
+          WHERE status IN (?,?,?) AND deleted = 0 AND created_at >= ?
           ORDER BY created_at ASC LIMIT 1
         |]
-        (SFSNew, SFSEncrypting, SFSEncrypted)
+        (SFSNew, SFSEncrypting, SFSEncrypted, cutoffTs)
   case fileId_ of
     Nothing -> pure Nothing
     Just fileId -> eitherToMaybe <$> getSndFile db fileId
@@ -2215,6 +2219,10 @@ 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)
 
+deleteSndFile' :: DB.Connection -> DBSndFileId -> IO ()
+deleteSndFile' db sndFileId =
+  DB.execute db "DELETE FROM snd_files WHERE snd_file_id = ?" (Only sndFileId)
+
 createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> IO ()
 createSndFileReplica db SndFileChunk {sndChunkId} NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
   srvId <- createXFTPServer_ db server
@@ -2237,8 +2245,9 @@ createSndFileReplica db SndFileChunk {sndChunkId} NewSndChunkReplica {server, re
       |]
       (rId, rcvId, rcvKey)
 
-getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> IO (Maybe SndFileChunk)
-getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} = do
+getNextSndChunkToUpload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Maybe SndFileChunk)
+getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
   chunk_ <-
     maybeFirstRow toChunk $
       DB.query
@@ -2254,11 +2263,11 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} = do
           JOIN snd_files f ON f.snd_file_id = c.snd_file_id
           WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ?
             AND r.replica_status = ? AND r.replica_number = 1
-            AND (f.status = ? OR f.status = ?) AND f.deleted = 0
+            AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ?
           ORDER BY r.created_at ASC
           LIMIT 1
         |]
-        (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading)
+        (host, port, keyHash, SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs)
   forM chunk_ $ \chunk@SndFileChunk {replicas} -> do
     replicas' <- forM replicas $ \replica@SndFileChunkReplica {sndChunkReplicaId} -> do
       rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
@@ -2304,3 +2313,36 @@ updateSndChunkReplicaStatus :: DB.Connection -> Int64 -> SndFileReplicaStatus ->
 updateSndChunkReplicaStatus db replicaId status = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE snd_file_chunk_replicas SET replica_status = ?, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (status, updatedAt, replicaId)
+
+getPendingSndFilesServers :: DB.Connection -> NominalDiffTime -> IO [XFTPServer]
+getPendingSndFilesServers db ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
+  map toServer
+    <$> DB.query
+      db
+      [sql|
+        SELECT DISTINCT
+          s.xftp_host, s.xftp_port, s.xftp_key_hash
+        FROM snd_file_chunk_replicas r
+        JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+        JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
+        JOIN snd_files f ON f.snd_file_id = c.snd_file_id
+        WHERE r.replica_status = ? AND r.replica_number = 1
+          AND (f.status = ? OR f.status = ?) AND f.deleted = 0 AND f.created_at >= ?
+      |]
+      (SFRSCreated, SFSEncrypted, SFSUploading, cutoffTs)
+  where
+    toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer
+    toServer (host, port, keyHash) = XFTPServer host port keyHash
+
+getSndFilesExpired :: DB.Connection -> NominalDiffTime -> IO [(DBSndFileId, SndFileId, Maybe FilePath)]
+getSndFilesExpired db ttl = do
+  cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
+  DB.query
+    db
+    [sql|
+      SELECT snd_file_id, snd_file_entity_id, prefix_path
+      FROM snd_files
+      WHERE created_at < ?
+    |]
+    (Only cutoffTs)