refactor

src/Simplex/FileTransfer/Agent.hs

@@ -54,7 +54,7 @@ import Simplex.FileTransfer.Chunks (toKB)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize)
 import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types
@@ -351,7 +351,7 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
 notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
 
-xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId
+xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AM SndFileId
 xftpSendFile' c userId file numRecipients credential storageTime = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "snd.xftp"
@@ -376,7 +376,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si
   liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing FSMaxTime
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing Nothing
   lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
@@ -455,7 +455,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
         srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of
           [] -> Left ch
           SndFileChunkReplica {server} : _ -> Right server
-        createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
+        createChunk :: Int -> Maybe EntitlementCredential -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
         createChunk numRecipients' credential storageTime ch = do
           liftIO $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate

src/Simplex/FileTransfer/Client.hs

@@ -20,7 +20,6 @@ module Simplex.FileTransfer.Client
     xftpClientServer,
     xftpTransportHost,
     createXFTPChunk,
-    createXFTPChunkStorage,
     addXFTPRecipients,
     uploadXFTPChunk,
     downloadXFTPChunk,
@@ -255,19 +254,10 @@ createXFTPChunk ::
   FileInfo ->
   NonEmpty C.APublicAuthKey ->
   Maybe BasicAuth ->
-  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSMaxTime Nothing
-
-createXFTPChunkStorage ::
-  XFTPClient ->
-  C.APrivateAuthKey ->
-  FileInfo ->
-  NonEmpty C.APublicAuthKey ->
-  Maybe BasicAuth ->
-  FileStorageTime ->
+  Maybe Int64 ->
   Maybe EntitlementProof ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunkStorage c spKey file rcps auth_ storageTime proof =
+createXFTPChunk c spKey file rcps auth_ storageTime proof =
   sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case
     (FRSndIds sId rIds _, body) -> noFile body (sId, rIds)
     (r, _) -> throwE $ unexpectedResponse r

src/Simplex/FileTransfer/Client/Main.hs

@@ -328,7 +328,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           digest <- liftIO $ getChunkDigest chunkSpec
           let ch = FileInfo {sndKey, size = chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
+          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth Nothing Nothing
           withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
           logDebug $ "uploaded chunk " <> tshow chunkNo
           uploaded <- atomically . stateTVar uploadedChunks $ \cs ->

src/Simplex/FileTransfer/Protocol.hs

@@ -22,7 +22,6 @@ module Simplex.FileTransfer.Protocol
     FileCommand (..),
     FileCmd (..),
     FileInfo (..),
-    FileStorageTime (..),
     GrantedStorageTime (..),
     xftpNewProofHeader,
     XFTPFileId,
@@ -181,7 +180,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
   {-# INLINE protocolError #-}
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender
+  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> Maybe EntitlementProof -> FileCommand FSender
   FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
   FPUT :: FileCommand FSender
   FDEL :: FileCommand FSender
@@ -202,19 +201,6 @@ data FileInfo = FileInfo
   }
   deriving (Show)
 
-data FileStorageTime = FSMaxTime | FSTime {hours :: Word32}
-  deriving (Eq, Show)
-
-instance Encoding FileStorageTime where
-  smpEncode = \case
-    FSMaxTime -> "M"
-    FSTime hours -> smpEncode ('F', hours)
-  smpP =
-    smpP >>= \case
-      'M' -> pure FSMaxTime
-      'F' -> FSTime <$> smpP
-      _ -> fail "bad FileStorageTime"
-
 data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
   deriving (Eq, Show)
 
@@ -223,10 +209,10 @@ xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEnc
 
 instance Encoding GrantedStorageTime where
   smpEncode = \case
-    GSTExpires t -> smpEncode ('F', t)
+    GSTExpires t -> smpEncode ('T', t)
   smpP =
     smpP >>= \case
-      'F' -> GSTExpires <$> smpP
+      'T' -> GSTExpires <$> smpP
       _ -> fail "bad GrantedStorageTime"
 
 type XFTPFileId = EntityId
@@ -235,8 +221,10 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
   type Tag (FileCommand p) = FileCommandTag p
   encodeProtocol v = \case
     FNEW file rKeys auth_ st ep
-      | v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep)
-      | otherwise -> e (FNEW_, ' ', file, rKeys, auth_)
+      | v >= fileStorageTimeXFTPVersion -> fnew <> e (st, ep)
+      | otherwise -> fnew
+      where
+        fnew = e (FNEW_, ' ', file, rKeys, auth_)
     FADD rKeys -> e (FADD_, ' ', rKeys)
     FPUT -> e FPUT_
     FDEL -> e FDEL_
@@ -274,8 +262,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
     FCT SFSender tag ->
       FileCmd SFSender <$> case tag of
         FNEW_
-          | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP
-          | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSMaxTime <*> pure Nothing
+          | v >= fileStorageTimeXFTPVersion -> fnewP smpP smpP
+          | otherwise -> fnewP (pure Nothing) (pure Nothing)
+          where
+            fnewP stP epP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP <*> epP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
@@ -329,7 +319,7 @@ instance ProtocolMsgTag FileResponseTag where
     _ -> Nothing
 
 data FileResponse
-  = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorageTime
+  = FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime)
   | FRRcvIds (NonEmpty RecipientId)
   | FRFile RcvPublicDhKey C.CbNonce
   | FROk
@@ -357,7 +347,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
   protocolP v = \case
     FRSndIds_
       | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP
-      | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure (GSTExpires 0)
+      | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure Nothing
     FRRcvIds_ -> FRRcvIds <$> _smpP
     FRFile_ -> FRFile <$> _smpP <*> smpP
     FROk_ -> pure FROk

src/Simplex/FileTransfer/Server.hs

@@ -35,7 +35,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
-import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+import Data.Time.Clock (UTCTime (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Data.X509 as X
@@ -128,12 +128,12 @@ data Handshake
 
 xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
 xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
-  when (isJust fileExpiration) $ expireServerFiles Nothing
+  expireServerFiles Nothing fileExpiration
   restoreServerStats
   raceAny_
     ( runServer
-        : expireFilesThread_ cfg
-          <> serverStatsThread_ cfg
+        : expireFiles fileExpiration
+        : serverStatsThread_ cfg
           <> prometheusMetricsThread_ cfg
           <> controlPortThread_ cfg
     )
@@ -246,16 +246,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       saveServerStats
       logNote "Server stopped"
 
-    expireFilesThread_ :: XFTPServerConfig s -> [M s ()]
-    expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
-    expireFilesThread_ _ = []
-
     expireFiles :: ExpirationConfig -> M s ()
     expireFiles expCfg = do
       let interval = checkInterval expCfg * 1000000
       forever $ do
         liftIO $ threadDelay' interval
-        expireServerFiles (Just 100000)
+        expireServerFiles (Just 100000) expCfg
 
     serverStatsThread_ :: XFTPServerConfig s -> [M s ()]
     serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -486,36 +482,38 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse
+    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> Maybe EntitlementProof -> M s FileResponse
     createFile file@FileInfo {sndKey, digest} rks storageTime ep = do
       st <- asks fileStore
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwE SIZE
         ts <- liftIO getFileTime
+        now <- liftIO $ roundedSeconds <$> getSystemSeconds
         maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep
-        let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime
+        let secs = maybe maxSeconds (\hours -> min (hours * 3600) maxSeconds) storageTime
+            fileExpiresAt = RoundedSystemTime $ ((now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
         -- TODO validate body empty
-        sId <- ExceptT $ addFileRetry st file 3 ts expiresAt
+        sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> do
-          logAddFile sl sId file ts expiresAt EntityActive
+          logAddFile sl sId file ts (Just fileExpiresAt) EntityActive
           logAddRecipients sl sId rcps
         stats <- asks serverStats
         lift $ incFileStat filesCreated
         liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
-        pure $ FRSndIds sId rIds granted
+        pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt)))
       pure $ either FRErr id r
-    storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64)
-    storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config
+    storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s Int64
+    storageMaxSeconds _ Nothing = asks $ ttl . fileExpiration . config
     storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do
       entCfg <- asks $ fileStorageEntitlements . config
-      defaultMax <- asks $ fmap ttl . fileExpiration . config
+      defaultMax <- asks $ ttl . fileExpiration . config
       now <- liftIO getCurrentTime
       let Entitlement {entitlementName, expiresAt} = ent
       liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case
-        Just True | expiresAt > now -> pure $ maybe defaultMax Just (M.lookup entitlementName entCfg)
+        Just True | addUTCTime nominalDay expiresAt > now -> pure $ fromMaybe defaultMax (M.lookup entitlementName entCfg)
         _ -> pure defaultMax
     addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
     addFileRetry st file n ts expiresAt =
@@ -658,33 +656,22 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
 getFileTime :: IO RoundedFileTime
 getFileTime = getRoundedSystemTime
 
-resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorageTime)
-resolveStorage base maxSeconds storageTime = (expiresAt, granted)
-  where
-    reqSeconds = case storageTime of
-      FSMaxTime -> maxSeconds
-      FSTime hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds
-    expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds
-    granted = GSTExpires $ base + fromMaybe 0 reqSeconds
-
-expireServerFiles :: FileStoreClass s => Maybe Int -> M s ()
-expireServerFiles itemDelay =
-  asks (fileExpiration . config) >>= \case
-    Nothing -> pure ()
-    Just ExpirationConfig {ttl = defaultTtl} -> do
-      st <- asks fileStore
-      us <- asks usedStorage
-      usedStart <- readTVarIO us
-      now <- liftIO $ roundedSeconds <$> getSystemSeconds
-      filesCount <- liftIO $ getFileCount st
-      logNote $ "Expiration check: " <> tshow filesCount <> " files"
-      expireLoop st us now defaultTtl
-      usedEnd <- readTVarIO us
-      logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
+expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
+expireServerFiles itemDelay expCfg = do
+  st <- asks fileStore
+  us <- asks usedStorage
+  usedStart <- readTVarIO us
+  now <- liftIO $ roundedSeconds <$> getSystemSeconds
+  old <- liftIO $ expireBeforeEpoch expCfg
+  filesCount <- liftIO $ getFileCount st
+  logNote $ "Expiration check: " <> tshow filesCount <> " files"
+  expireLoop st us now old
+  usedEnd <- readTVarIO us
+  logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
   where
     mbs bs = tshow (bs `div` 1048576) <> "mb"
-    expireLoop st us now defaultTtl = do
-      expired <- liftIO $ expiredFiles st now defaultTtl 10000
+    expireLoop st us now old = do
+      expired <- liftIO $ expiredFiles st now old 10000
       forM_ expired $ \(sId, filePath_, fileSize) -> do
         mapM_ threadDelay itemDelay
         forM_ filePath_ $ \fp ->
@@ -697,7 +684,7 @@ expireServerFiles itemDelay =
       unless (null sIds) $ do
         withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds
         liftIO $ deleteFiles st sIds
-        expireLoop st us now defaultTtl
+        expireLoop st us now old
 
 randomId :: Int -> M s ByteString
 randomId n = atomically . C.randomBytes n =<< asks random

src/Simplex/FileTransfer/Server/Env.hs

@@ -45,7 +45,7 @@ import Data.Word (Word32)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
 import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.FileTransfer.Server.Stats
 import Data.Either (fromRight)
@@ -92,7 +92,7 @@ data XFTPServerConfig s = XFTPServerConfig
     controlPortUserAuth :: Maybe BasicAuth,
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the files can be removed and check interval, seconds
-    fileExpiration :: Maybe ExpirationConfig,
+    fileExpiration :: ExpirationConfig,
     -- | maximum storage time per entitlement name, seconds
     fileStorageEntitlements :: Map Text Int64,
     -- | timeout to receive file
@@ -166,6 +166,9 @@ fromFileStore = \case
 #endif
 {-# INLINE fromFileStore #-}
 
+defFileExpirationHours :: Int64
+defFileExpirationHours = 48
+
 defaultFileExpiration :: ExpirationConfig
 defaultFileExpiration =
   ExpirationConfig
@@ -173,14 +176,10 @@ defaultFileExpiration =
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 
-storageAtLeast :: Int64 -> Maybe Int64 -> Bool
-storageAtLeast _ Nothing = True
-storageAtLeast a (Just b) = a >= b
-
 newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
 newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
-  let defaultMax = ttl <$> fileExpiration
-  unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ do
+  let defaultMax = ttl fileExpiration
+  unless (all (>= defaultMax) (M.elems fileStorageEntitlements)) $ do
     logError "STORE: entitlement storage time is below the default file expiration"
     exitFailure
   random <- C.newRandom
@@ -207,7 +206,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExp
   pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
 
 data XFTPRequest
-  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof)
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Int64) (Maybe EntitlementProof)
   | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing
 

src/Simplex/FileTransfer/Server/Main.hs

@@ -242,9 +242,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
           putStrLn $ case storeLogFile of
             Just f -> "Store log: " <> f
             _ -> "Store log disabled."
-          putStrLn $ case fileExpiration of
-            Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
-            _ -> "not expiring files"
+          putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration)
           putStrLn $ case inactiveClientExpiration of
             Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
             _ -> "not expiring inactive clients"
@@ -290,10 +288,9 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
               controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
               controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
               fileExpiration =
-                Just
-                  defaultFileExpiration
-                    { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
-                    },
+                defaultFileExpiration
+                  { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
+                  },
               fileStorageEntitlements = iniEntitlements ini,
               fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
               inactiveClientExpiration =
@@ -444,7 +441,7 @@ cliCommandP cfgPath logPath iniFile =
 
 iniEntitlements :: Ini -> Map T.Text Int64
 iniEntitlements ini =
-  M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")]
+  M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")]
   where
     readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini))
     parseMax t = (3600 *) <$> (readMaybe (T.unpack (T.strip t)) :: Maybe Int64)

src/Simplex/FileTransfer/Server/Store.hs

@@ -16,7 +16,6 @@ module Simplex.FileTransfer.Server.Store
     STMFileStore (..),
     RoundedFileTime,
     fileTimePrecision,
-    defFileExpirationHours,
   )
 where
 
@@ -65,9 +64,6 @@ type RoundedFileTime = RoundedSystemTime 3600
 fileTimePrecision :: Int64
 fileTimePrecision = 3600
 
-defFileExpirationHours :: Int64
-defFileExpirationHours = 48
-
 data FileRecipient = FileRecipient RecipientId C.APublicAuthKey
   deriving (Show)
 
@@ -171,11 +167,13 @@ instance FileStoreClass STMFileStore where
           pure $ Right ()
       _ -> pure $ Left AUTH
 
-  expiredFiles STMFileStore {files} now defaultTtl _limit = do
+  expiredFiles STMFileStore {files} now old _limit = do
     fs <- readTVarIO files
     fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) ->
-      let effExpiry = maybe (createdAt + defaultTtl) roundedSeconds expiresAt
-       in if effExpiry < now
+      let expired = case expiresAt of
+            Just e -> roundedSeconds e < now
+            Nothing -> createdAt + fileTimePrecision < old
+       in if expired
             then do
               path <- readTVarIO filePath
               pure $ Just (sId, path, size)

src/Simplex/FileTransfer/Server/Store/Postgres.hs

@@ -152,12 +152,12 @@ instance FileStoreClass PostgresFileStore where
       DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId)
     withLog "ackFile" st $ \s -> logAckFile s rId
 
-  expiredFiles st now defaultTtl limit =
+  expiredFiles st now old limit =
     fmap toResult $ withTransaction (dbStore st) $ \db ->
       DB.query
         db
         "SELECT sender_id, file_path, file_size FROM files WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?"
-        (now, now - defaultTtl, limit)
+        (now, old - fileTimePrecision, limit)
     where
       toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
       toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))

src/Simplex/FileTransfer/Types.hs

@@ -39,10 +39,8 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Word (Word32)
-import Text.Read (readMaybe)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileStorageTime (..))
 import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
@@ -174,7 +172,7 @@ data SndFile = SndFile
     deleted :: Bool,
     redirect :: Maybe RedirectFileInfo,
     entitlementCredential :: Maybe EntitlementCredential,
-    storageTime :: FileStorageTime
+    storageTime :: Maybe Int64
   }
   deriving (Show)
 
@@ -194,21 +192,6 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode
 
 instance ToField SndFileStatus where toField = toField . textEncode
 
-fileStorageTimeText :: FileStorageTime -> Text
-fileStorageTimeText = \case
-  FSMaxTime -> "max"
-  FSTime h -> "for " <> T.pack (show h)
-
-fileStorageTimeParse :: Text -> Maybe FileStorageTime
-fileStorageTimeParse s = case T.words s of
-  ["max"] -> Just FSMaxTime
-  ["for", h] -> FSTime <$> readMaybe (T.unpack h)
-  _ -> Nothing
-
-instance ToField FileStorageTime where toField = toField . fileStorageTimeText
-
-instance FromField FileStorageTime where fromField = fromTextField_ fileStorageTimeParse
-
 instance ToField EntitlementCredential where toField = toField . decodeUtf8 . LB.toStrict . JD.encode
 
 instance FromField EntitlementCredential where fromField = fromTextField_ (JD.decode . LB.fromStrict . encodeUtf8)

src/Simplex/Messaging/Agent.hs

@@ -191,7 +191,7 @@ import Data.Traversable (mapAccumL)
 import Data.Word (Word16)
 import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
 import Simplex.FileTransfer.Description (ValidFileDescription)
-import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..))
+import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
 import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
@@ -776,10 +776,10 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
 
 -- | Send XFTP file
 xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
-xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSMaxTime
+xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing Nothing
 {-# INLINE xftpSendFile #-}
 
-xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId
+xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId
 xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime
 {-# INLINE xftpSendFileStorage #-}
 

src/Simplex/Messaging/Agent/Client.hs

@@ -233,7 +233,7 @@ import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
 import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
-import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, FileStorageTime, xftpNewProofHeader)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, xftpNewProofHeader)
 import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
@@ -253,7 +253,7 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
 import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), EntitlementProof, entitlementIssuerKeys, generateEntitlementProof)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), entitlementIssuerKeys, generateEntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
@@ -1346,7 +1346,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
         let file = FileInfo {sndKey, size = chSize, digest}
             chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
         r <- runExceptT $ do
-          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
+          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth Nothing Nothing
           liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
           liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
           rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
@@ -2187,7 +2187,7 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se
   g <- asks random
   withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec
 
-agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> FileStorageTime -> AM NewSndChunkReplica
+agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> Maybe Int64 -> AM NewSndChunkReplica
 agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) credential storageTime = do
   rKeys <- xftpRcvKeys n
   (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
@@ -2195,18 +2195,15 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
   logServer "-->" c srv NoEntity "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
   (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> do
-    proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey chunkDigest credential
-    X.createXFTPChunkStorage xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof
+    proof <- liftIO $ case credential of
+      Nothing -> pure Nothing
+      Just cred@EntitlementCredential {issuerKeyIdx} -> case M.lookup issuerKeyIdx entitlementIssuerKeys of
+        Nothing -> pure Nothing
+        Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader (sessionId $ X.thParams xftp) sndKey chunkDigest)
+    X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof
   logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
   pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
 
-mkEntitlementProof :: SessionId -> C.APublicAuthKey -> ByteString -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof)
-mkEntitlementProof _ _ _ Nothing = pure Nothing
-mkEntitlementProof sessId sndKey digest (Just cred@EntitlementCredential {issuerKeyIdx}) =
-  case M.lookup issuerKeyIdx entitlementIssuerKeys of
-    Nothing -> pure Nothing
-    Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey digest)
-
 agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
 agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
   withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec

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

@@ -309,7 +309,7 @@ import Network.Socket (ServiceName)
 import qualified Network.TLS as TLS
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
 import Simplex.FileTransfer.Types
 import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Agent.Protocol
@@ -3425,7 +3425,7 @@ getRcvFilesExpired db ttl = do
     |]
     (Only cutoffTs)
 
-createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId)
+createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> Maybe Int64 -> IO (Either StoreError SndFileId)
 createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime =
   createWithRandomId db gVar $ \sndFileEntityId ->
     DB.execute
@@ -3477,7 +3477,7 @@ getSndFile db sndFileId = runExceptT $ do
           )
           (Only sndFileId)
       where
-        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe EntitlementCredential, FileStorageTime) -> SndFile
+        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe EntitlementCredential, Maybe Int64) -> SndFile
         toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) =
           let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
               srcFile = CryptoFile srcPath cfArgs

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs

@@ -10,7 +10,7 @@ m20260823_snd_files_entitlement :: Text
 m20260823_snd_files_entitlement =
   [r|
 ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT;
-ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max';
+ALTER TABLE snd_files ADD COLUMN storage_time BIGINT;
 |]
 
 down_m20260823_snd_files_entitlement :: Text

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

@@ -9,7 +9,7 @@ m20260823_snd_files_entitlement :: Query
 m20260823_snd_files_entitlement =
   [sql|
 ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT;
-ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max';
+ALTER TABLE snd_files ADD COLUMN storage_time INTEGER;
   |]
 
 down_m20260823_snd_files_entitlement :: Query