xftp server: round down file creation time to 1 hour (#1310)

src/Simplex/FileTransfer/Server.hs

@@ -33,7 +33,6 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
-import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Data.X509 as X
@@ -57,6 +56,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (CorrId (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, TransmissionAuth, pattern NoEntity)
 import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime, getRoundedSystemTime)
 import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
@@ -399,7 +399,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwE SIZE
-        ts <- liftIO getSystemTime
+        ts <- liftIO getFileTime
         -- TODO validate body empty
         sId <- ExceptT $ addFileRetry st file 3 ts
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
@@ -412,7 +412,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRSndIds sId rIds
       pure $ either FRErr id r
-    addFileRetry :: FileStore -> FileInfo -> Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId)
+    addFileRetry :: FileStore -> FileInfo -> Int -> RoundedSystemTime -> M (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts =
       retryAdd n $ \sId -> runExceptT $ do
         ExceptT $ addFile st sId file ts
@@ -531,6 +531,9 @@ deleteServerFile_ FileRec {senderId, fileInfo, filePath} = do
       liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
       liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
+getFileTime :: IO RoundedSystemTime
+getFileTime = getRoundedSystemTime fileTimePrecision
+
 expireServerFiles :: Maybe Int -> ExpirationConfig -> M ()
 expireServerFiles itemDelay expCfg = do
   st <- asks store

src/Simplex/FileTransfer/Server/Store.hs

@@ -17,6 +17,7 @@ module Simplex.FileTransfer.Server.Store
     expiredFilePath,
     getFile,
     ackFile,
+    fileTimePrecision,
   )
 where
 
@@ -25,12 +26,12 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Int (Int64)
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Time.Clock.System (SystemTime (..))
 import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId)
 import Simplex.FileTransfer.Transport (XFTPErrorType (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime (..))
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util (ifM, ($>>=))
@@ -46,9 +47,12 @@ data FileRec = FileRec
     fileInfo :: FileInfo,
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
-    createdAt :: SystemTime
+    createdAt :: RoundedSystemTime
   }
 
+fileTimePrecision :: Int64
+fileTimePrecision = 3600 -- truncate creation time to 1 hour
+
 data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey
 
 instance StrEncoding FileRecipient where
@@ -62,14 +66,14 @@ newFileStore = do
   usedStorage <- newTVarIO 0
   pure FileStore {files, recipients, usedStorage}
 
-addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ())
+addFile :: FileStore -> SenderId -> FileInfo -> RoundedSystemTime -> STM (Either XFTPErrorType ())
 addFile FileStore {files} sId fileInfo createdAt =
   ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
     f <- newFileRec sId fileInfo createdAt
     TM.insert sId f files
     pure $ Right ()
 
-newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec
+newFileRec :: SenderId -> FileInfo -> RoundedSystemTime -> STM FileRec
 newFileRec senderId fileInfo createdAt = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
@@ -120,8 +124,8 @@ getFile st party fId = case party of
 expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe (Maybe FilePath))
 expiredFilePath FileStore {files} sId old =
   TM.lookup sId files
-    $>>= \FileRec {filePath, createdAt} ->
-      if systemSeconds createdAt < old
+    $>>= \FileRec {filePath, createdAt = RoundedSystemTime createdAt} ->
+      if createdAt + fileTimePrecision < old
         then Just <$> readTVar filePath
         else pure Nothing
 

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -28,18 +28,18 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Time.Clock.System (SystemTime)
 import Simplex.FileTransfer.Protocol (FileInfo (..))
 import Simplex.FileTransfer.Server.Store
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId)
+import Simplex.Messaging.Server.QueueStore (RoundedSystemTime)
 import Simplex.Messaging.Server.StoreLog
 import Simplex.Messaging.Util (bshow, whenM)
 import System.Directory (doesFileExist, renameFile)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo SystemTime
+  = AddFile SenderId FileInfo RoundedSystemTime
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
@@ -64,7 +64,7 @@ instance StrEncoding FileStoreLogRecord where
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO ()
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedSystemTime -> IO ()
 logAddFile s = logFileStoreRecord s .:. AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()