fixes

plans/2026-08-22-xftp-file-storage-time.md

@@ -55,7 +55,7 @@ In `Simplex.FileTransfer.Protocol`:
 data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
 ```
 
-- add the storage time (`Maybe Word32`: `Nothing` requests the server maximum, `Just` a number of hours) to `FNEW`
+- add the storage time (`Maybe Word32`: `Nothing` and `Just 0` request the server maximum, a value above zero requests that number of hours) to `FNEW`
 - add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version)
 
 ## simplexmq: server configuration
@@ -71,7 +71,7 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
 
 In `Simplex.FileTransfer.Server`:
 
-- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. It takes the resolution as a parameter: the first handshake verifies, a repeated handshake with the `xftp-handshake` header keeps the entitlement of the session and verifies nothing
+- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. `HandshakeSent` carries `EntitlementChecked`, so the first handshake verifies and every later one on that connection reuses the result, including after `processHello` returns the session to `HandshakeSent`
 - verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum
 - a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed
 - `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise
@@ -114,7 +114,7 @@ Per-user state in `Simplex.Messaging.Agent.Env.SQLite` and `Simplex.Messaging.Ag
 Public API in `Simplex.Messaging.Agent`:
 
 - add storage time (`Maybe Word32` hours) to `xftpSendFile`
-- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and closes that user's XFTP clients, so the next upload presents the new credential
+- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and when the credential changed it closes that user's XFTP clients, so the next upload presents the new credential
 
 Store, in both the SQLite and PostgreSQL agent stores:
 

rfcs/2026-08-22-xftp-file-storage-time.md

@@ -38,7 +38,7 @@ fileStorageTime = %s"0" / (%s"1" storageHours)
 storageHours = 4*4 OCTET     ; Word32, network byte order
 ```
 
-The storage time is an optional number of hours. Absent (`%s"0"`) requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value (`%s"1"` with hours) requests a specific number of hours.
+The storage time is an optional number of hours. Absent (`%s"0"`), or present as zero hours, requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value above zero requests that number of hours, and the server grants the smaller of it and the maximum.
 
 ## Handshake, new XFTP version
 
@@ -51,7 +51,7 @@ optEntitlementProof = %s"0" / (%s"1" entitlementProof)
 
 `xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof.
 
-The server verifies the proof when it accepts the handshake and keeps the result for the session; a repeated handshake carrying the `xftp-handshake` header keeps that result and verifies nothing. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures.
+The server verifies the proof when it accepts the handshake and keeps the result for the session; further handshakes on the same connection keep that result and verify nothing, so a session costs one verification however many handshakes it makes. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures.
 
 ## Commands
 

src/Simplex/FileTransfer/Agent.hs

@@ -352,7 +352,7 @@ notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEv
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
 
 xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId
-xftpSendFile' c userId file numRecipients storageTime = do
+xftpSendFile' c userId file numRecipients storageHours = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
@@ -360,7 +360,7 @@ xftpSendFile' c userId file numRecipients storageTime = do
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageTime
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours
   lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
@@ -406,7 +406,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
     prepareFile _ SndFile {prefixPath = Nothing} =
       throwE $ INTERNAL "no prefix path"
     prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do
-      SndFile {numRecipients, chunks, storageTime} <-
+      SndFile {numRecipients, chunks, storageHours} <-
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
             fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
@@ -425,7 +425,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
       let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks
       -- concurrently?
       -- separate worker to create chunks? record retries and delay on snd_file_chunks?
-      srvs <- forM pendingChunks $ createChunk numRecipients' storageTime
+      srvs <- forM pendingChunks $ createChunk numRecipients' storageHours
       let allSrvs = S.fromList $ preparedSrvs <> srvs
       lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv)
       withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
@@ -456,7 +456,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
           [] -> Left ch
           SndFileChunkReplica {server} : _ -> Right server
         createChunk :: Int -> Maybe Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
-        createChunk numRecipients' storageTime ch = do
+        createChunk numRecipients' storageHours ch = do
           liftIO $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
@@ -483,7 +483,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
               deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
               when deleted $ throwE $ FILE NO_FILE
               withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
-                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageTime
+                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageHours
                 pure (replica, srvAuth)
 
 sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()

src/Simplex/FileTransfer/Client.hs

@@ -258,8 +258,8 @@ createXFTPChunk ::
   Maybe BasicAuth ->
   Maybe Word32 ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime)
-createXFTPChunk c spKey file rcps auth_ storageTime =
-  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime) Nothing >>= \case
+createXFTPChunk c spKey file rcps auth_ storageHours =
+  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageHours) Nothing >>= \case
     (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs)
     (r, _) -> throwE $ unexpectedResponse r
 

src/Simplex/FileTransfer/Server.hs

@@ -124,9 +124,12 @@ runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s ->
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
 data Handshake
-  = HandshakeSent C.PrivateKeyX25519
+  = HandshakeSent C.PrivateKeyX25519 EntitlementChecked
   | HandshakeAccepted (THandleParams XFTPVersion 'TServer)
 
+-- | the entitlement of the session is resolved once, however many handshakes it has
+data EntitlementChecked = EntNotChecked | EntChecked (Maybe SessionEntitlement)
+
 xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
 xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
   expireServerFiles Nothing fileExpiration
@@ -178,12 +181,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         Nothing
           | sniUsed && not webHello -> throwE SESSION
           | otherwise -> processHello Nothing
-        Just (HandshakeSent pk)
+        Just (HandshakeSent pk ent_)
           | webHello -> processHello (Just pk)
-          | otherwise -> processClientHandshake pk verifiedEntitlement
+          | otherwise -> processClientHandshake pk ent_
         Just (HandshakeAccepted thParams)
           | webHello -> processHello (serverPrivKey <$> thAuth thParams)
-          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (const . pure $ peerEntitlement auth)
+          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (EntChecked $ peerEntitlement auth)
           | otherwise -> pure $ Just thParams
       either sendError pure r
       where
@@ -200,10 +203,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               | otherwise -> throwE HANDSHAKE
           rng <- asks random
           k <- atomically $ TM.lookup sessionId sessions >>= \case
-            Just (HandshakeSent pk') -> pure $ C.publicKey pk'
-            _ -> do
+            Just (HandshakeSent pk' _) -> pure $ C.publicKey pk'
+            s' -> do
               kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_
-              fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions
+              let ent_ = case s' of
+                    Just (HandshakeAccepted thParams) -> EntChecked $ peerEntitlement =<< thAuth thParams
+                    _ -> EntNotChecked
+              fst kp <$ TM.insert sessionId (HandshakeSent (snd kp) ent_) sessions
           let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
               webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_
           let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof}
@@ -213,7 +219,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
 #endif
           liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs
           pure Nothing
-        processClientHandshake pk sessionEntitlement = do
+        processClientHandshake pk ent_ = do
           unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE
           body <- liftHS $ C.unPad bodyHead
           XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body
@@ -221,7 +227,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (keyHash == kh) $ throwE HANDSHAKE
           case compatibleVRange' xftpServerVRange v of
             Just (Compatible vr) -> do
-              ent <- lift $ sessionEntitlement entitlementProof
+              ent <- case ent_ of
+                EntChecked ent -> pure ent
+                EntNotChecked -> lift $ verifiedEntitlement entitlementProof
               let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing}
                   thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
               atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
@@ -481,7 +489,7 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
 
 processXFTPRequest :: forall s. FileStoreClass s => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
 processXFTPRequest ent HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rks auth storageTime -> noFile =<< ifM allowNew (createFile file rks storageTime) (pure $ FRErr AUTH)
+  XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH)
     where
       allowNew = do
         XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
@@ -499,16 +507,19 @@ processXFTPRequest ent HTTP2Body {bodyPart} = \case
   where
     noFile resp = pure (resp, Nothing)
     createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse
-    createFile file rks storageTime = do
+    createFile file rks storageHours = do
       st <- asks fileStore
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwE SIZE
-        ts <- liftIO getFileTime
         now <- liftIO getSystemSeconds
         maxSeconds <- lift $ storageMaxSeconds now
-        let secs = maybe maxSeconds (\hours -> min maxSeconds (fromIntegral hours * 3600)) storageTime
-            fileExpiresAt = RoundedSystemTime $ ((roundedSeconds now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
+        let nowSeconds = roundedSeconds now
+            ts = RoundedSystemTime $ (nowSeconds `div` fileTimePrecision) * fileTimePrecision
+            secs = case storageHours of
+              Just hours | hours > 0 -> min maxSeconds (fromIntegral hours * 3600)
+              _ -> maxSeconds
+            fileExpiresAt = RoundedSystemTime $ ((nowSeconds + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
         -- TODO validate body empty
         sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
@@ -668,15 +679,12 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
 entitlementValid :: SystemSeconds -> SystemSeconds -> Bool
 entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now
 
-getFileTime :: IO RoundedFileTime
-getFileTime = getRoundedSystemTime
-
 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
+  now <- liftIO getSystemSeconds
   old <- liftIO $ expireBeforeEpoch expCfg
   filesCount <- liftIO $ getFileCount st
   logNote $ "Expiration check: " <> tshow filesCount <> " files"

src/Simplex/FileTransfer/Server/Main.hs

@@ -160,10 +160,12 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
                \# db_pool_size = 10\n\n\
                \# Write database changes to store log file\n\
                \# db_store_log = off\n\n"
-            <> "# Expire files after the specified number of hours.\n"
+            <> "# Expire files after the specified number of hours.\n\
+               \# The change only affects new files.\n"
             <> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n")
             <> "# Expire files after the specified number of hours for the senders that present\n\
                \# a proof of the entitlement. Must not be below expire_files_hours.\n\
+               \# The change only affects new files.\n\
                \# expire_files_hours_for_supporter = 168\n\
                \# expire_files_hours_for_legend = 504\n\n"
             <> "log_stats = off\n\

src/Simplex/FileTransfer/Server/Store.hs

@@ -85,7 +85,7 @@ class FileStoreClass s where
   deleteRecipient :: s -> RecipientId -> FileRec -> IO ()
   getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey))
   ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ())
-  expiredFiles :: s -> Int64 -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
+  expiredFiles :: s -> SystemSeconds -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
   getUsedStorage :: s -> IO Int64
   getFileCount :: s -> IO Int
 
@@ -171,7 +171,7 @@ instance FileStoreClass STMFileStore where
     fs <- readTVarIO files
     fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) ->
       let expired = case expiresAt of
-            Just e -> roundedSeconds e < now
+            Just e -> roundedSeconds e < roundedSeconds now
             Nothing -> createdAt + fileTimePrecision < old
        in if expired
             then do

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

@@ -55,6 +55,7 @@ import Simplex.Messaging.Transport (EntityId (..))
 import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
 import Simplex.Messaging.Server.QueueStore.Postgres ()
 import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
+import Simplex.Messaging.SystemTime (roundedSeconds)
 import Simplex.Messaging.Util (firstRow, tshow)
 import System.Directory (renameFile)
 import System.Exit (exitFailure)
@@ -157,7 +158,7 @@ instance FileStoreClass PostgresFileStore where
       DB.query
         db
         "(SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)"
-        (now, limit, old - fileTimePrecision, limit)
+        (roundedSeconds now, limit, 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

@@ -169,7 +169,7 @@ data SndFile = SndFile
     status :: SndFileStatus,
     deleted :: Bool,
     redirect :: Maybe RedirectFileInfo,
-    storageTime :: Maybe Word32
+    storageHours :: Maybe Word32
   }
   deriving (Show)
 

src/Simplex/Messaging/Agent.hs

@@ -3055,8 +3055,12 @@ setProtocolServers c userId srvs = do
 -- The credential is presented in the handshake, so the user's XFTP clients are closed to present the new one.
 setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()
 setUserEntitlement c userId cred_ = do
-  atomically $ maybe (TM.delete userId) (TM.insert userId) cred_ $ userEntitlements c
-  closeUserXFTPClients c userId
+  changed <- atomically $ do
+    prev_ <- TM.lookup userId $ userEntitlements c
+    if prev_ == cred_
+      then pure False
+      else True <$ maybe (TM.delete userId) (TM.insert userId) cred_ (userEntitlements c)
+  when changed $ closeUserXFTPClients c userId
 
 checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO ()
 checkUserServers name srvs =

src/Simplex/Messaging/Agent/Client.hs

@@ -227,14 +227,14 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
-import Data.Time.Clock.System (getSystemTime)
+import Data.Time.Clock.System (getSystemTime, systemSeconds)
 import Data.Word (Word16, Word32)
 import qualified Data.X509.Validation as XV
 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)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, GrantedStorageTime (..))
 import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
@@ -901,10 +901,18 @@ getXFTPServerClient c@AgentClient {active, xftpClients, userEntitlements, worker
 
     mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof)
     mkEntitlementProof keys sessId =
-      TM.lookupIO userId userEntitlements $>>= \cred ->
-        generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case
-          Right p -> pure $ Just p
-          Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)
+      ifM knownServer proof (pure Nothing)
+      where
+        -- the entitlement is presented only to the servers of this user, matched by key hash that TLS pins,
+        -- so a file description of the sender cannot direct it to another server
+        knownServer = maybe False (any (sameKeyHash . snd) . storageSrvs) <$> TM.lookupIO userId (xftpServers c)
+        sameKeyHash (ProtoServerWithAuth srv' _) = srvKeyHash srv' == srvKeyHash srv
+        srvKeyHash (ProtocolServer _ _ _ kh) = kh
+        proof =
+          TM.lookupIO userId userEntitlements $>>= \cred ->
+            generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case
+              Right p -> pure $ Just p
+              Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)
 
     clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
     clientDisconnected v client = do
@@ -2208,15 +2216,20 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se
   withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec
 
 agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica
-agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageTime = do
+agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageHours = do
   rKeys <- xftpRcvKeys n
   (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
   let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
   logServer "-->" c srv NoEntity "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
   (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp ->
-    X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime
+    X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageHours
   logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
+  liftIO $ forM_ ((,) <$> storageHours <*> expiresAt) $ \(hours, GSTExpires t) -> do
+    now <- systemSeconds <$> getSystemTime
+    let granted = (t - now + 3599) `div` 3600
+    when (granted < fromIntegral hours) $
+      logWarn $ "requested " <> tshow hours <> " hours of storage, granted " <> tshow granted
   pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt}
 
 agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()

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

@@ -3425,12 +3425,12 @@ getRcvFilesExpired db ttl = do
     (Only cutoffTs)
 
 createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Word32 -> IO (Either StoreError SndFileId)
-createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageTime =
+createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageHours =
   createWithRandomId db gVar $ \sndFileEntityId ->
     DB.execute
       db
       "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
-      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageTime))
+      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageHours))
   where
     (redirectSize_, redirectDigest_) =
       case redirect_ of
@@ -3477,11 +3477,11 @@ 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 Word32) -> SndFile
-        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageTime)) =
+        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageHours)) =
           let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
               srcFile = CryptoFile srcPath cfArgs
               redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_
-           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageTime, chunks = []}
+           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageHours, chunks = []}
     getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
     getChunks sndFileEntityId userId numRecipients filePrefixPath = do
       chunks <-

tests/CoreTests/StoreLogTests.hs

@@ -209,6 +209,25 @@ deriving instance Eq FileStoreLogRecord
 testFileStoreLogFile :: FilePath
 testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
 
+fileExpirationTests :: Spec
+fileExpirationTests =
+  describe "XFTP file expiration" $
+    it "expires by stored expiration and by creation time" testExpiredFiles
+
+testExpiredFiles :: Expectation
+testExpiredFiles = do
+  st <- newFileStore () :: IO STMFileStore
+  g <- C.newRandom
+  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
+      created = RoundedSystemTime 100000
+  addFile st (EntityId "expired_stored__") file created (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "stored_ahead____") file created (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "legacy_expired__") file created Nothing EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "legacy_in_grace_") file (RoundedSystemTime 297000) Nothing EntityActive `shouldReturn` Right ()
+  expired <- expiredFiles st (RoundedSystemTime 500000) 300000 100
+  map (\(sId, _, _) -> sId) expired `shouldMatchList` [EntityId "expired_stored__", EntityId "legacy_expired__"]
+
 fileStoreLogTests :: Spec
 fileStoreLogTests = do
   g <- runIO C.newRandom

tests/CoreTests/XFTPStoreTests.hs

@@ -197,7 +197,7 @@ testExpiredFiles = withPgStore $ \st -> do
   void $ setFilePath st (EntityId "old_file________") "/tmp/old"
   addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right ()
   -- Query expired with cutoff that only catches old file
-  expired <- expiredFiles st 500000 500000 100
+  expired <- expiredFiles st (RoundedSystemTime 500000) 500000 100
   length expired `shouldBe` 1
   case expired of
     [(sId, path, sz)] -> do
@@ -215,7 +215,7 @@ testExpiredFilesStoredExpiration = withPgStore $ \st -> do
   -- both files are created before the cutoff, the stored expiration decides
   addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
   addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
-  expired <- expiredFiles st 500000 0 100
+  expired <- expiredFiles st (RoundedSystemTime 500000) 0 100
   map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
 
 testStorageAndCount :: Expectation

tests/Test.hs

@@ -98,6 +98,7 @@ main = do
           describe "Store log tests" storeLogTests
 #endif
           describe "XFTP store log tests" fileStoreLogTests
+          fileExpirationTests
           describe "TSessionSubs tests" tSessionSubsTests
           describe "Util tests" utilTests
           describe "Names resolver tests" smpNamesTests