implementation

simplexmq.cabal

@@ -193,6 +193,7 @@ library
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
           Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -246,6 +247,7 @@ library
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
           Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
           Simplex.Messaging.Agent.Store.SQLite.Util
   if flag(client_postgres) || flag(server_postgres)
       exposed-modules:

src/Simplex/FileTransfer/Agent.hs

@@ -22,6 +22,7 @@ module Simplex.FileTransfer.Agent
     -- Sending files
     xftpSendFile',
     xftpSendDescription',
+    xftpSetFileTime',
     deleteSndFileInternal,
     deleteSndFilesInternal,
     deleteSndFileRemote,
@@ -54,7 +55,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 (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage, SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types
@@ -68,6 +69,7 @@ import Simplex.Messaging.Agent.Stats
 import Simplex.Messaging.Agent.Store.AgentStore
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import qualified Simplex.Messaging.Crypto.Lazy as LC
@@ -350,8 +352,8 @@ 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 -> AM SndFileId
-xftpSendFile' c userId file numRecipients = do
+xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId
+xftpSendFile' c userId file numRecipients credential storageTime = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
@@ -359,7 +361,7 @@ xftpSendFile' c userId file numRecipients = 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
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing credential storageTime
   lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
@@ -375,7 +377,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}
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing FSTMax
   lift . void $ getXFTPSndWorker True c Nothing
   pure fId
 
@@ -405,7 +407,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} <-
+      SndFile {numRecipients, chunks, entitlementCredential, storageTime} <-
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
             fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
@@ -424,7 +426,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'
+      srvs <- forM pendingChunks $ createChunk numRecipients' entitlementCredential storageTime
       let allSrvs = S.fromList $ preparedSrvs <> srvs
       lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv)
       withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
@@ -454,8 +456,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
         srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of
           [] -> Left ch
           SndFileChunkReplica {server} : _ -> Right server
-        createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
-        createChunk numRecipients' ch = do
+        createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
+        createChunk numRecipients' credential storageTime ch = do
           liftIO $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
@@ -482,7 +484,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
+                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth credential storageTime
                 pure (replica, srvAuth)
 
 sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
@@ -639,6 +641,15 @@ deleteSndFilesInternal c sndFileEntityIds = do
     batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> AM' ()
     batchFiles_ f sndFiles = void $ withStoreBatch' c $ \db -> map (\SndFile {sndFileId} -> f db sndFileId) sndFiles
 
+xftpSetFileTime' :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AM [GrantedStorage]
+xftpSetFileTime' c userId (ValidFileDescription FileDescription {chunks}) storageTime credential =
+  forM (mapMaybe chunkReplica chunks) $ \(server, replicaId, replicaKey, digest) ->
+    agentXFTPSetChunkTime c userId server replicaId replicaKey digest storageTime credential
+  where
+    chunkReplica = \case
+      FileChunk {digest, replicas = FileChunkReplica {server, replicaId, replicaKey} : _} -> Just (server, replicaId, replicaKey, digest)
+      _ -> Nothing
+
 deleteSndFileRemote :: AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> AM' ()
 deleteSndFileRemote c userId sndFileEntityId sfd = deleteSndFilesRemote c userId [(sndFileEntityId, sfd)]
 

src/Simplex/FileTransfer/Client.hs

@@ -20,6 +20,8 @@ module Simplex.FileTransfer.Client
     xftpClientServer,
     xftpTransportHost,
     createXFTPChunk,
+    createXFTPChunkStorage,
+    setXFTPChunkTime,
     addXFTPRecipients,
     uploadXFTPChunk,
     downloadXFTPChunk,
@@ -57,6 +59,7 @@ import Network.Socket (HostName)
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
     NetworkRequestMode (..),
@@ -254,9 +257,26 @@ createXFTPChunk ::
   NonEmpty C.APublicAuthKey ->
   Maybe BasicAuth ->
   ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunk c spKey file rcps auth_ =
-  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
-    (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
+createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSTMax Nothing
+
+createXFTPChunkStorage ::
+  XFTPClient ->
+  C.APrivateAuthKey ->
+  FileInfo ->
+  NonEmpty C.APublicAuthKey ->
+  Maybe BasicAuth ->
+  FileStorageTime ->
+  Maybe EntitlementProof ->
+  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
+createXFTPChunkStorage 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
+
+setXFTPChunkTime :: XFTPClient -> C.APrivateAuthKey -> SenderId -> FileStorageTime -> Maybe EntitlementProof -> ExceptT XFTPClientError IO GrantedStorage
+setXFTPChunkTime c spKey sId storageTime proof =
+  sendXFTPCommand c spKey sId (FTTL storageTime proof) Nothing >>= \case
+    (FRFileTime gs, body) -> noFile body gs
     (r, _) -> throwE $ unexpectedResponse r
 
 addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)

src/Simplex/FileTransfer/Protocol.hs

@@ -22,6 +22,10 @@ module Simplex.FileTransfer.Protocol
     FileCommand (..),
     FileCmd (..),
     FileInfo (..),
+    FileStorageTime (..),
+    GrantedStorage (..),
+    xftpNewProofHeader,
+    xftpTimeProofHeader,
     XFTPFileId,
     FileResponse (..),
     xftpBlockSize,
@@ -38,14 +42,17 @@ import qualified Data.Aeson.TH as J
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
-import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub)
+import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub)
 import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
@@ -77,7 +84,7 @@ import Simplex.Messaging.Protocol
     tEncodeBatch1,
     tParse,
   )
-import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
+import Simplex.Messaging.Transport (SessionId, THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Util ((<$?>))
 
 xftpBlockSize :: Int
@@ -123,6 +130,7 @@ data FileCommandTag (p :: FileParty) where
   FADD_ :: FileCommandTag FSender
   FPUT_ :: FileCommandTag FSender
   FDEL_ :: FileCommandTag FSender
+  FTTL_ :: FileCommandTag FSender
   FGET_ :: FileCommandTag FRecipient
   FACK_ :: FileCommandTag FRecipient
   PING_ :: FileCommandTag FRecipient
@@ -137,6 +145,7 @@ instance FilePartyI p => Encoding (FileCommandTag p) where
     FADD_ -> "FADD"
     FPUT_ -> "FPUT"
     FDEL_ -> "FDEL"
+    FTTL_ -> "FTTL"
     FGET_ -> "FGET"
     FACK_ -> "FACK"
     PING_ -> "PING"
@@ -152,6 +161,7 @@ instance ProtocolMsgTag FileCmdTag where
     "FADD" -> Just $ FCT SFSender FADD_
     "FPUT" -> Just $ FCT SFSender FPUT_
     "FDEL" -> Just $ FCT SFSender FDEL_
+    "FTTL" -> Just $ FCT SFSender FTTL_
     "FGET" -> Just $ FCT SFRecipient FGET_
     "FACK" -> Just $ FCT SFRecipient FACK_
     "PING" -> Just $ FCT SFRecipient PING_
@@ -175,10 +185,11 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
   {-# INLINE protocolError #-}
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
+  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender
   FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
   FPUT :: FileCommand FSender
   FDEL :: FileCommand FSender
+  FTTL :: FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender
   FGET :: RcvPublicDhKey -> FileCommand FRecipient
   FACK :: FileCommand FRecipient
   PING :: FileCommand FRecipient
@@ -196,15 +207,50 @@ data FileInfo = FileInfo
   }
   deriving (Show)
 
+data FileStorageTime = FSTMax | FSTFor Word32
+  deriving (Eq, Show)
+
+instance Encoding FileStorageTime where
+  smpEncode = \case
+    FSTMax -> "M"
+    FSTFor hours -> smpEncode ('F', hours)
+  smpP =
+    smpP >>= \case
+      'M' -> pure FSTMax
+      'F' -> FSTFor <$> smpP
+      _ -> fail "bad FileStorageTime"
+
+data GrantedStorage = GrantedExpires Int64 | GrantedPermanent
+  deriving (Eq, Show)
+
+xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader
+xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest
+
+xftpTimeProofHeader :: SessionId -> SenderId -> BBSPresHeader
+xftpTimeProofHeader sessionId sId = BBSPresHeader $ sessionId <> unEntityId sId
+
+instance Encoding GrantedStorage where
+  smpEncode = \case
+    GrantedExpires t -> smpEncode ('F', t)
+    GrantedPermanent -> "P"
+  smpP =
+    smpP >>= \case
+      'F' -> GrantedExpires <$> smpP
+      'P' -> pure GrantedPermanent
+      _ -> fail "bad GrantedStorage"
+
 type XFTPFileId = EntityId
 
 instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
-  encodeProtocol _v = \case
-    FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
+  encodeProtocol v = \case
+    FNEW file rKeys auth_ st ep
+      | v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep)
+      | otherwise -> e (FNEW_, ' ', file, rKeys, auth_)
     FADD rKeys -> e (FADD_, ' ', rKeys)
     FPUT -> e FPUT_
     FDEL -> e FDEL_
+    FTTL st ep -> e (FTTL_, ' ', st, ep)
     FGET rKey -> e (FGET_, ' ', rKey)
     FACK -> e FACK_
     PING -> e PING_
@@ -235,13 +281,16 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
   type Tag FileCmd = FileCmdTag
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
-  protocolP _v = \case
+  protocolP v = \case
     FCT SFSender tag ->
       FileCmd SFSender <$> case tag of
-        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
+        FNEW_
+          | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP
+          | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSTMax <*> pure Nothing
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
+        FTTL_ -> FTTL <$> _smpP <*> smpP
     FCT SFRecipient tag ->
       FileCmd SFRecipient <$> case tag of
         FGET_ -> FGET <$> _smpP
@@ -266,6 +315,7 @@ data FileResponseTag
   = FRSndIds_
   | FRRcvIds_
   | FRFile_
+  | FRFileTime_
   | FROk_
   | FRErr_
   | FRPong_
@@ -276,6 +326,7 @@ instance Encoding FileResponseTag where
     FRSndIds_ -> "SIDS"
     FRRcvIds_ -> "RIDS"
     FRFile_ -> "FILE"
+    FRFileTime_ -> "TTL"
     FROk_ -> "OK"
     FRErr_ -> "ERR"
     FRPong_ -> "PONG"
@@ -286,15 +337,17 @@ instance ProtocolMsgTag FileResponseTag where
     "SIDS" -> Just FRSndIds_
     "RIDS" -> Just FRRcvIds_
     "FILE" -> Just FRFile_
+    "TTL" -> Just FRFileTime_
     "OK" -> Just FROk_
     "ERR" -> Just FRErr_
     "PONG" -> Just FRPong_
     _ -> Nothing
 
 data FileResponse
-  = FRSndIds SenderId (NonEmpty RecipientId)
+  = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorage
   | FRRcvIds (NonEmpty RecipientId)
   | FRFile RcvPublicDhKey C.CbNonce
+  | FRFileTime GrantedStorage
   | FROk
   | FRErr XFTPErrorType
   | FRPong
@@ -303,9 +356,12 @@ data FileResponse
 instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
   type Tag FileResponse = FileResponseTag
   encodeProtocol v = \case
-    FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
+    FRSndIds fId rIds gs
+      | v >= fileStorageTimeXFTPVersion -> e (FRSndIds_, ' ', fId, rIds, gs)
+      | otherwise -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
     FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
+    FRFileTime gs -> e (FRFileTime_, ' ', gs)
     FROk -> e FROk_
     FRErr err -> case err of
       BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH)
@@ -315,10 +371,13 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP _v = \case
-    FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
+  protocolP v = \case
+    FRSndIds_
+      | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP
+      | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure GrantedPermanent
     FRRcvIds_ -> FRRcvIds <$> _smpP
     FRFile_ -> FRFile <$> _smpP <*> smpP
+    FRFileTime_ -> FRFileTime <$> _smpP
     FROk_ -> pure FROk
     FRErr_ -> FRErr <$> _smpP
     FRPong_ -> pure FRPong

src/Simplex/FileTransfer/Server.hs

@@ -30,6 +30,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Map.Strict as M
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
@@ -54,6 +55,8 @@ import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader)
+import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), entitlementIssuerKeys, verifyEntitlement)
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -125,7 +128,7 @@ data Handshake
 
 xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
 xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
-  mapM_ (expireServerFiles Nothing) fileExpiration
+  when (isJust fileExpiration) $ expireServerFiles Nothing
   restoreServerStats
   raceAny_
     ( runServer
@@ -252,7 +255,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       let interval = checkInterval expCfg * 1000000
       forever $ do
         liftIO $ threadDelay' interval
-        expireServerFiles (Just 100000) expCfg
+        expireServerFiles (Just 100000)
 
     serverStatsThread_ :: XFTPServerConfig s -> [M s ()]
     serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
@@ -401,9 +404,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
   | otherwise =
       case xftpDecodeTServer thParams bodyHead of
         Right (Right t@(_, _, (corrId, fId, _))) -> do
-          let THandleParams {thAuth} = thParams
+          let THandleParams {thAuth, sessionId} = thParams
           verifyXFTPTransmission thAuth t >>= \case
-            VRVerified req -> uncurry send =<< processXFTPRequest body req
+            VRVerified req -> uncurry send =<< processXFTPRequest sessionId body req
             VRFailed e -> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
@@ -443,7 +446,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
 verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult
 verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
   case cmd of
-    FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
+    FileCmd SFSender (FNEW file rcps auth' st ep) -> pure $ XFTPReqNew file rcps auth' st ep `verifyWith` sndKey file
     FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
     FileCmd party _ -> verifyCmd party
   where
@@ -464,9 +467,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
     -- TODO verify with DH authorization
     req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
 
-processXFTPRequest :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
-processXFTPRequest HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH)
+processXFTPRequest :: forall s. FileStoreClass s => SessionId -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
+processXFTPRequest sessionId HTTP2Body {bodyPart} = \case
+  XFTPReqNew file rks auth storageTime ep -> noFile =<< ifM allowNew (createFile file rks storageTime ep) (pure $ FRErr AUTH)
     where
       allowNew = do
         XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
@@ -477,35 +480,59 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
     FDEL -> noFile =<< deleteServerFile fr
     FGET rDhKey -> sendServerFile fr rDhKey
     FACK -> noFile =<< ackFileReception fId fr
+    FTTL storageTime ep -> noFile =<< setFileTime fId storageTime ep
     -- it should never get to the commands below, they are passed in other constructors of XFTPRequest
     FNEW {} -> noFile $ FRErr INTERNAL
     PING -> noFile $ FRErr INTERNAL
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse
-    createFile file rks = do
+    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> 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
+        maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep
+        let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime
         -- TODO validate body empty
-        sId <- ExceptT $ addFileRetry st file 3 ts
+        sId <- ExceptT $ addFileRetry st file 3 ts expiresAt
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> do
-          logAddFile sl sId file ts EntityActive
+          logAddFile sl sId file ts expiresAt 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
+        pure $ FRSndIds sId rIds granted
       pure $ either FRErr id r
-    addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
-    addFileRetry st file n ts =
+    setFileTime :: XFTPFileId -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse
+    setFileTime sId storageTime ep = do
+      st <- asks fileStore
+      maxSeconds <- storageMaxSeconds (xftpTimeProofHeader sessionId sId) ep
+      now <- liftIO $ roundedSeconds <$> getSystemSeconds
+      let (expiresAt, granted) = resolveStorage now maxSeconds storageTime
+      liftIO (setFileExpiration st sId expiresAt) >>= \case
+        Right () -> do
+          withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt
+          pure $ FRFileTime granted
+        Left e -> pure $ FRErr e
+    storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64)
+    storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config
+    storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do
+      entCfg <- asks $ fileStorageEntitlements . config
+      defaultMax <- asks $ fmap ttl . fileExpiration . config
+      now <- liftIO getCurrentTime
+      let Entitlement {entitlementName, expiresAt} = ent
+      liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case
+        Just True | 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 =
       retryAdd n $ \sId -> runExceptT $ do
-        ExceptT $ addFile st sId file ts EntityActive
+        ExceptT $ addFile st sId file ts expiresAt EntityActive
         pure sId
     addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient)
     addRecipientRetry st n sId rpk =
@@ -643,21 +670,30 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
 getFileTime :: IO RoundedFileTime
 getFileTime = getRoundedSystemTime
 
-expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
-expireServerFiles itemDelay expCfg = do
+resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorage)
+resolveStorage base maxSeconds storageTime = (expiresAt, granted)
+  where
+    reqSeconds = case storageTime of
+      FSTMax -> maxSeconds
+      FSTFor hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds
+    expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds
+    granted = maybe GrantedPermanent (\(RoundedSystemTime t) -> GrantedExpires t) expiresAt
+
+expireServerFiles :: FileStoreClass s => Maybe Int -> M s ()
+expireServerFiles itemDelay = do
   st <- asks fileStore
   us <- asks usedStorage
   usedStart <- readTVarIO us
-  old <- liftIO $ expireBeforeEpoch expCfg
+  now <- liftIO $ roundedSeconds <$> getSystemSeconds
   filesCount <- liftIO $ getFileCount st
   logNote $ "Expiration check: " <> tshow filesCount <> " files"
-  expireLoop st us old
+  expireLoop st us now
   usedEnd <- readTVarIO us
   logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
   where
     mbs bs = tshow (bs `div` 1048576) <> "mb"
-    expireLoop st us old = do
-      expired <- liftIO $ expiredFiles st old 10000
+    expireLoop st us now = do
+      expired <- liftIO $ expiredFiles st now 10000
       forM_ expired $ \(sId, filePath_, fileSize) -> do
         mapM_ threadDelay itemDelay
         forM_ filePath_ $ \fp ->
@@ -670,7 +706,7 @@ expireServerFiles itemDelay expCfg = do
       unless (null sIds) $ do
         withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds
         liftIO $ deleteFiles st sIds
-        expireLoop st us old
+        expireLoop st us now
 
 randomId :: Int -> M s ByteString
 randomId n = atomically . C.randomBytes n =<< asks random

src/Simplex/FileTransfer/Server/Env.hs

@@ -37,12 +37,16 @@ import Control.Monad
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Data.Word (Word32)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.FileTransfer.Server.Stats
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
@@ -89,6 +93,8 @@ data XFTPServerConfig s = XFTPServerConfig
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the files can be removed and check interval, seconds
     fileExpiration :: Maybe ExpirationConfig,
+    -- | maximum storage time per entitlement name, seconds; Nothing value is permanent
+    fileStorageEntitlements :: Map Text (Maybe Int64),
     -- | timeout to receive file
     fileTimeout :: Int,
     -- | time after which inactive clients can be disconnected and check interval, seconds
@@ -160,9 +166,6 @@ fromFileStore = \case
 #endif
 {-# INLINE fromFileStore #-}
 
-defFileExpirationHours :: Int64
-defFileExpirationHours = 48
-
 defaultFileExpiration :: ExpirationConfig
 defaultFileExpiration =
   ExpirationConfig
@@ -170,8 +173,17 @@ defaultFileExpiration =
       checkInterval = 2 * 3600 -- seconds, 2 hours
     }
 
+storageAtLeast :: Maybe Int64 -> Maybe Int64 -> Bool
+storageAtLeast Nothing _ = True
+storageAtLeast (Just _) Nothing = False
+storageAtLeast (Just a) (Just b) = a >= b
+
 newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
-newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do
+newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
+  let defaultMax = ttl <$> fileExpiration
+  unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ do
+    logError "STORE: entitlement storage time is below the default file expiration"
+    exitFailure
   random <- C.newRandom
   (store, storeLog) <- case serverStoreCfg of
     XSCMemory storeLogPath -> do
@@ -196,7 +208,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCre
   pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
 
 data XFTPRequest
-  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof)
   | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing
 

src/Simplex/FileTransfer/Server/Main.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Server.Main
@@ -16,11 +17,13 @@ module Simplex.FileTransfer.Server.Main
 import Control.Monad (unless, when)
 import Data.Either (fromRight)
 import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
+import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.Int (Int64)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.List (find)
 import qualified Data.List.NonEmpty as L
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -291,6 +294,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
                   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 =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
@@ -437,3 +441,12 @@ cliCommandP cfgPath logPath iniFile =
         ( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database"))
             <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file"))
         )
+
+iniEntitlements :: Ini -> Map T.Text (Maybe Int64)
+iniEntitlements ini =
+  M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")]
+  where
+    readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini))
+    parseMax t = case T.strip t of
+      "permanent" -> Just Nothing
+      s -> Just . (3600 *) <$> (readMaybe (T.unpack s) :: Maybe Int64)

src/Simplex/FileTransfer/Server/Store.hs

@@ -16,6 +16,7 @@ module Simplex.FileTransfer.Server.Store
     STMFileStore (..),
     RoundedFileTime,
     fileTimePrecision,
+    defFileExpirationHours,
   )
 where
 
@@ -55,6 +56,7 @@ data FileRec = FileRec
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
     createdAt :: RoundedFileTime,
+    expiresAt :: Maybe RoundedFileTime,
     fileStatus :: TVar ServerEntityStatus
   }
 
@@ -63,6 +65,9 @@ type RoundedFileTime = RoundedSystemTime 3600
 fileTimePrecision :: Int64
 fileTimePrecision = 3600
 
+defFileExpirationHours :: Int64
+defFileExpirationHours = 48
+
 data FileRecipient = FileRecipient RecipientId C.APublicAuthKey
   deriving (Show)
 
@@ -74,8 +79,9 @@ class FileStoreClass s where
   type FileStoreConfig s
   newFileStore :: FileStoreConfig s -> IO s
   closeFileStore :: s -> IO ()
-  addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
+  addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
   setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ())
+  setFileExpiration :: s -> SenderId -> Maybe RoundedFileTime -> IO (Either XFTPErrorType ())
   addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
   deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ())
   deleteFiles :: s -> [SenderId] -> IO ()
@@ -107,9 +113,9 @@ instance FileStoreClass STMFileStore where
 
   closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog
 
-  addFile STMFileStore {files} sId fileInfo createdAt status = atomically $
+  addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $
     ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
-      f <- newFileRec sId fileInfo createdAt status
+      f <- newFileRec sId fileInfo createdAt expiresAt status
       TM.insert sId f files
       pure $ Right ()
 
@@ -124,6 +130,11 @@ instance FileStoreClass STMFileStore where
               pure $ Right ()
             _ -> pure $ Left AUTH
 
+  setFileExpiration STMFileStore {files} sId expiresAt = atomically $
+    TM.lookup sId files >>= \case
+      Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt} files
+      _ -> pure $ Left AUTH
+
   addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $
     withFile st senderId $ \FileRec {recipientIds} -> do
       rIds <- readTVar recipientIds
@@ -166,14 +177,14 @@ instance FileStoreClass STMFileStore where
           pure $ Right ()
       _ -> pure $ Left AUTH
 
-  expiredFiles STMFileStore {files} old _limit = do
+  expiredFiles STMFileStore {files} now _limit = do
     fs <- readTVarIO files
-    fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) ->
-      if createdAt + fileTimePrecision < old
-        then do
+    fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, expiresAt}) ->
+      case expiresAt of
+        Just (RoundedSystemTime t) | t < now -> do
           path <- readTVarIO filePath
           pure $ Just (sId, path, size)
-        else pure Nothing
+        _ -> pure Nothing
 
   getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files
     where
@@ -184,12 +195,12 @@ instance FileStoreClass STMFileStore where
 
 -- Internal STM helpers
 
-newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
-newFileRec senderId fileInfo createdAt status = do
+newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec
+newFileRec senderId fileInfo createdAt expiresAt status = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
   fileStatus <- newTVar status
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
 
 withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a)
 withFile STMFileStore {files} sId a =

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

@@ -82,23 +82,28 @@ instance FileStoreClass PostgresFileStore where
     closeDBStore dbStore
     mapM_ closeStoreLog dbStoreLog
 
-  addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt status =
+  addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status =
     E.uninterruptibleMask_ $ runExceptT $ do
       void $ withDB "addFile" st $ \db ->
         E.try
           ( DB.execute
               db
-              "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, status) VALUES (?,?,?,?,?,?)"
-              (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, status)
+              "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)"
+              (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status)
           )
           >>= either handleDuplicate (pure . Right)
-      withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt status
+      withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status
 
   setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do
     assertUpdated $ withDB' "setFilePath" st $ \db ->
       DB.execute db "UPDATE files SET file_path = ? WHERE sender_id = ? AND file_path IS NULL AND status = 'active'" (fPath, sId)
     withLog "setFilePath" st $ \s -> logPutFile s sId fPath
 
+  setFileExpiration st sId expiresAt = E.uninterruptibleMask_ $ runExceptT $ do
+    assertUpdated $ withDB' "setFileExpiration" st $ \db ->
+      DB.execute db "UPDATE files SET expires_at = ? WHERE sender_id = ?" (expiresAt, sId)
+    withLog "setFileExpiration" st $ \s -> logSetFileExpiration s sId expiresAt
+
   addRecipient st senderId (FileRecipient rId rKey) = E.uninterruptibleMask_ $ runExceptT $ do
     void $ withDB "addRecipient" st $ \db ->
       E.try
@@ -131,13 +136,13 @@ instance FileStoreClass PostgresFileStore where
 
   getFile st party fId = runExceptT $ case party of
     SFSender -> do
-      row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files WHERE sender_id = ?"
+      row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?"
       fr <- ExceptT $ rowToFileRec row
       pure (fr, sndKey (fileInfo fr))
     SFRecipient -> do
       row :. Only rcpKeyBs <-
         loadFileRow
-          "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
+          "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
       fr <- ExceptT $ rowToFileRec row
       rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs
       pure (fr, rcpKey)
@@ -152,12 +157,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 old limit =
+  expiredFiles st now limit =
     fmap toResult $ withTransaction (dbStore st) $ \db ->
       DB.query
         db
-        "SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?"
-        (fileTimePrecision, old, limit)
+        "SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? ORDER BY expires_at LIMIT ?"
+        (now, limit)
     where
       toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
       toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))
@@ -174,21 +179,21 @@ instance FileStoreClass PostgresFileStore where
 
 -- Internal helpers
 
-mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> ServerEntityStatus -> IO FileRec
-mkFileRec senderId fileInfo path createdAt status = do
+mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec
+mkFileRec senderId fileInfo path createdAt expiresAt status = do
   filePath <- newTVarIO path
   recipientIds <- newTVarIO S.empty
   fileStatus <- newTVarIO status
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
 
-type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, ServerEntityStatus)
+type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
 
 rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec)
-rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, status) =
+rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) =
   case C.decodePubKey sndKeyBs of
     Right sndKey -> do
       let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
-      Right <$> mkFileRec sId fileInfo path createdAt status
+      Right <$> mkFileRec sId fileInfo path createdAt expiresAt status
     Left _ -> pure $ Left INTERNAL
 
 -- DB helpers
@@ -243,7 +248,7 @@ importFileStore storeLogFilePath dbCfg = do
   fCnt <- withTransaction (dbStore pgStore) $ \db -> do
     DB.copy_
       db
-      "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, status) FROM STDIN WITH (FORMAT csv)"
+      "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)"
     iforM_ (M.toList allFiles) $ \i (sId, fr) -> do
       DB.putCopyData db =<< fileRecToCSV sId fr
       when (i > 0 && i `mod` 10000 == 0) $ putStr ("  " <> show i <> " files\r") >> hFlush stdout
@@ -282,13 +287,13 @@ exportFileStore storeLogFilePath dbCfg = do
   !fCnt <- withTransaction (dbStore pgStore) $ \db ->
     DB.fold_
       db
-      "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files ORDER BY created_at"
+      "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at"
       (0 :: Int)
-      ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, status) ->
+      ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) ->
           case C.decodePubKey sndKeyBs of
             Right sndKey -> do
               let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
-              logAddFile sl sId fileInfo createdAt status
+              logAddFile sl sId fileInfo createdAt expiresAt status
               forM_ path $ logPutFile sl sId
               pure (fc + 1)
             Left _ -> do
@@ -326,7 +331,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m ()
 iforM_ xs f = zipWithM_ f [0 ..] xs
 
 fileRecToCSV :: SenderId -> FileRec -> IO ByteString
-fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, fileStatus} = do
+fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do
   path <- readTVarIO filePath
   status <- readTVarIO fileStatus
   pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n'
@@ -338,6 +343,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath,
         renderField (toField (Binary (C.encodePubKey sndKey))),
         nullable (toField <$> path),
         renderField (toField createdAt),
+        nullable (toField <$> expiresAt),
         quotedField (toField status)
       ]
 

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

@@ -14,7 +14,8 @@ import Text.RawString.QQ (r)
 
 xftpSchemaMigrations :: [(String, Text, Maybe Text)]
 xftpSchemaMigrations =
-  [ ("20260325_initial", m20260325_initial, Nothing)
+  [ ("20260325_initial", m20260325_initial, Nothing),
+    ("20260823_file_expiration", m20260823_file_expiration, Just down_m20260823_file_expiration)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -45,3 +46,18 @@ CREATE TABLE recipients (
 CREATE INDEX idx_recipients_sender_id ON recipients (sender_id);
 CREATE INDEX idx_files_created_at ON files (created_at);
 |]
+
+m20260823_file_expiration :: Text
+m20260823_file_expiration =
+  [r|
+ALTER TABLE files ADD COLUMN expires_at BIGINT;
+UPDATE files SET expires_at = created_at + 48 * 3600;
+CREATE INDEX idx_files_expires_at ON files (expires_at);
+|]
+
+down_m20260823_file_expiration :: Text
+down_m20260823_file_expiration =
+  [r|
+DROP INDEX idx_files_expires_at;
+ALTER TABLE files DROP COLUMN expires_at;
+|]

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -12,6 +12,7 @@ module Simplex.FileTransfer.Server.StoreLog
     readWriteFileStore,
     writeFileStore,
     logAddFile,
+    logSetFileExpiration,
     logPutFile,
     logAddRecipients,
     logDeleteFile,
@@ -26,7 +27,7 @@ import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Composition ((.:), (.::))
+import Data.Composition ((.:))
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -38,41 +39,58 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId)
 import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
 import Simplex.Messaging.Server.StoreLog
+import Simplex.Messaging.SystemTime (RoundedSystemTime (..))
 import Simplex.Messaging.Util (bshow)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus
+  = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
   | BlockFile SenderId BlockingInfo
   | AckFile RecipientId -- TODO add senderId as well?
+  | SetFileExpiration SenderId (Maybe RoundedFileTime)
   deriving (Show)
 
 instance StrEncoding FileStoreLogRecord where
   strEncode = \case
-    AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status)
+    AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> " " <> maybe "P" strEncode expiresAt
     PutFile sId path -> strEncode (Str "FPUT", sId, path)
     AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
     DeleteFile sId -> strEncode (Str "FDEL", sId)
     BlockFile sId info -> strEncode (Str "FBLK", sId, info)
     AckFile rId -> strEncode (Str "FACK", rId)
+    SetFileExpiration sId expiresAt -> strEncode (Str "FTTL", sId) <> " " <> maybe "P" strEncode expiresAt
   strP =
     A.choice
-      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)),
+      [ "FNEW " *> addFileP,
         "FPUT " *> (PutFile <$> strP_ <*> strP),
         "FADD " *> (AddRecipients <$> strP_ <*> strP),
         "FDEL " *> (DeleteFile <$> strP),
         "FBLK " *> (BlockFile <$> strP_ <*> strP),
-        "FACK " *> (AckFile <$> strP)
+        "FACK " *> (AckFile <$> strP),
+        "FTTL " *> (SetFileExpiration <$> strP_ <*> expiryP)
       ]
+    where
+      addFileP = do
+        sId <- strP_
+        file <- strP_
+        createdAt <- strP
+        status <- _strP <|> pure EntityActive
+        expiresAt <- (A.space *> expiryP) <|> pure (Just $ legacyExpiry createdAt)
+        pure $ AddFile sId file createdAt expiresAt status
+      expiryP = (Nothing <$ A.char 'P') <|> (Just <$> strP)
+      legacyExpiry (RoundedSystemTime c) = RoundedSystemTime (c + defFileExpirationHours * 3600)
 
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO ()
-logAddFile s = logFileStoreRecord s .:: AddFile
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO ()
+logAddFile s sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status
+
+logSetFileExpiration :: StoreLog 'WriteMode -> SenderId -> Maybe RoundedFileTime -> IO ()
+logSetFileExpiration s sId expiresAt = logFileStoreRecord s $ SetFileExpiration sId expiresAt
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
@@ -102,14 +120,15 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
           Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
           _ -> pure ()
     addToStore = \case
-      AddFile sId file createdAt status
-        | size file > 0 -> addFile st sId file createdAt status
+      AddFile sId file createdAt expiresAt status
+        | size file > 0 -> addFile st sId file createdAt expiresAt status
         | otherwise -> pure $ Left SIZE
       PutFile qId path -> setFilePath st qId path
       AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
       DeleteFile sId -> deleteFile st sId
       BlockFile sId info -> blockFile st sId info True
       AckFile rId -> ackFile st rId
+      SetFileExpiration sId expiresAt -> setFileExpiration st sId expiresAt
     addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps
 
 writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO ()
@@ -118,9 +137,9 @@ writeFileStore s STMFileStore {files, recipients} = do
   readTVarIO files >>= mapM_ (logFile allRcps)
   where
     logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
-    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do
+    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do
       status <- readTVarIO fileStatus
-      logAddFile s senderId fileInfo createdAt status
+      logAddFile s senderId fileInfo createdAt expiresAt status
       (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
       mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
       mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs

src/Simplex/FileTransfer/Transport.hs

@@ -12,6 +12,7 @@ module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
     authCmdsXFTPVersion,
     blockedFilesXFTPVersion,
+    fileStorageTimeXFTPVersion,
     xftpClientHandshakeStub,
     alpnSupportedXFTPhandshakes,
     xftpALPNv1,
@@ -97,8 +98,11 @@ authCmdsXFTPVersion = VersionXFTP 2
 blockedFilesXFTPVersion :: VersionXFTP
 blockedFilesXFTPVersion = VersionXFTP 3
 
+fileStorageTimeXFTPVersion :: VersionXFTP
+fileStorageTimeXFTPVersion = VersionXFTP 4
+
 currentXFTPVersion :: VersionXFTP
-currentXFTPVersion = VersionXFTP 3
+currentXFTPVersion = VersionXFTP 4
 
 supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion

src/Simplex/FileTransfer/Types.hs

@@ -29,16 +29,21 @@ module Simplex.FileTransfer.Types
     sndChunkSize,
   ) where
 
+import qualified Data.Aeson as JD
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+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
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -167,7 +172,9 @@ data SndFile = SndFile
     prefixPath :: Maybe FilePath,
     status :: SndFileStatus,
     deleted :: Bool,
-    redirect :: Maybe RedirectFileInfo
+    redirect :: Maybe RedirectFileInfo,
+    entitlementCredential :: Maybe EntitlementCredential,
+    storageTime :: FileStorageTime
   }
   deriving (Show)
 
@@ -187,6 +194,25 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode
 
 instance ToField SndFileStatus where toField = toField . textEncode
 
+fileStorageTimeText :: FileStorageTime -> Text
+fileStorageTimeText = \case
+  FSTMax -> "max"
+  FSTFor h -> "for " <> T.pack (show h)
+
+fileStorageTimeParse :: Text -> Maybe FileStorageTime
+fileStorageTimeParse s = case T.words s of
+  ["max"] -> Just FSTMax
+  ["for", h] -> FSTFor <$> 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)
+
 instance TextEncoding SndFileStatus where
   textDecode = \case
     "new" -> Just SFSNew

src/Simplex/Messaging/Agent.hs

@@ -128,7 +128,9 @@ module Simplex.Messaging.Agent
     xftpDeleteRcvFile,
     xftpDeleteRcvFiles,
     xftpSendFile,
+    xftpSendFileStorage,
     xftpSendDescription,
+    xftpSetFileTime,
     xftpDeleteSndFileInternal,
     xftpDeleteSndFilesInternal,
     xftpDeleteSndFileRemote,
@@ -188,9 +190,9 @@ import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 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.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile', xftpSetFileTime')
 import Simplex.FileTransfer.Description (ValidFileDescription)
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage)
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
 import Simplex.FileTransfer.Util (removePath)
 import Simplex.Messaging.Agent.Client
@@ -211,6 +213,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo)
 import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -774,14 +777,23 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
 
 -- | Send XFTP file
 xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
-xftpSendFile c = withAgentEnv c .:. xftpSendFile' c
+xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSTMax
 {-# INLINE xftpSendFile #-}
 
+xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId
+xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime
+{-# INLINE xftpSendFileStorage #-}
+
 -- | Send XFTP file
 xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId
 xftpSendDescription c = withAgentEnv c .:. xftpSendDescription' c
 {-# INLINE xftpSendDescription #-}
 
+-- | Set XFTP file storage time on the server (all chunks in the sender description)
+xftpSetFileTime :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AE [GrantedStorage]
+xftpSetFileTime c userId vfd storageTime credential = withAgentEnv c $ xftpSetFileTime' c userId vfd storageTime credential
+{-# INLINE xftpSetFileTime #-}
+
 -- | Delete XFTP snd file internally (deletes work files from file system and db records)
 xftpDeleteSndFileInternal :: AgentClient -> SndFileId -> IO ()
 xftpDeleteSndFileInternal c = withAgentEnv' c . deleteSndFileInternal c

src/Simplex/Messaging/Agent/Client.hs

@@ -94,6 +94,7 @@ module Simplex.Messaging.Agent.Client
     agentXFTPUploadChunk,
     agentXFTPAddRecipients,
     agentXFTPDeleteChunk,
+    agentXFTPSetChunkTime,
     agentCbDecrypt,
     cryptoError,
     sendAck,
@@ -233,7 +234,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)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, FileStorageTime, GrantedStorage, xftpNewProofHeader, xftpTimeProofHeader)
 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,6 +254,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.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
@@ -2186,17 +2188,26 @@ 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 -> AM NewSndChunkReplica
-agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
+agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> FileStorageTime -> 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
   let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
   logServer "-->" c srv NoEntity "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
-  (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
+  (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
   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
@@ -2211,6 +2222,19 @@ agentXFTPDeleteChunk :: AgentClient -> UserId -> DeletedSndChunkReplica -> AM ()
 agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} =
   withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId
 
+agentXFTPSetChunkTime :: AgentClient -> UserId -> XFTPServer -> ChunkReplicaId -> C.APrivateAuthKey -> FileDigest -> FileStorageTime -> Maybe EntitlementCredential -> AM GrantedStorage
+agentXFTPSetChunkTime c userId server (ChunkReplicaId fId) replicaKey (FileDigest chunkDigest) storageTime credential =
+  withXFTPClient c (userId, server, chunkDigest) "FTTL" $ \xftp -> do
+    proof <- liftIO $ mkEntitlementTimeProof (sessionId $ X.thParams xftp) fId credential
+    X.setXFTPChunkTime xftp replicaKey fId storageTime proof
+
+mkEntitlementTimeProof :: SessionId -> SMP.SenderId -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof)
+mkEntitlementTimeProof _ _ Nothing = pure Nothing
+mkEntitlementTimeProof sessId sId (Just cred@EntitlementCredential {issuerKeyIdx}) =
+  case M.lookup issuerKeyIdx entitlementIssuerKeys of
+    Nothing -> pure Nothing
+    Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpTimeProofHeader sessId sId)
+
 xftpRcvKeys :: Int -> AM (NonEmpty C.AAuthKeyPair)
 xftpRcvKeys n = do
   rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random

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

@@ -309,8 +309,9 @@ import Network.Socket (ServiceName)
 import qualified Network.TLS as TLS
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..))
 import Simplex.FileTransfer.Types
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
 import Simplex.Messaging.Agent.Stats
@@ -3424,13 +3425,13 @@ getRcvFilesExpired db ttl = do
     |]
     (Only cutoffTs)
 
-createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId)
-createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ =
+createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId)
+createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime =
   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) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
-      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_))
+      "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, entitlement_credential, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, entitlementCredential, storageTime))
   where
     (redirectSize_, redirectDigest_) =
       case redirect_ of
@@ -3466,7 +3467,7 @@ getSndFile db sndFileId = runExceptT $ do
         DB.query
           db
           ( [sql|
-              SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest
+              SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, entitlement_credential, storage_time
               FROM snd_files
               WHERE snd_file_id = ?
             |]
@@ -3476,12 +3477,12 @@ 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) -> SndFile
-        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) =
+        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 ((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
               redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_
-           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []}
+           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, entitlementCredential, storageTime, chunks = []}
     getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
     getChunks sndFileEntityId userId numRecipients filePrefixPath = do
       chunks <-

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

@@ -14,6 +14,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251230_strict_tables
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
 import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Text, Maybe Text)]
@@ -27,7 +28,8 @@ schemaMigrations =
     ("20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables),
     ("20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts),
     ("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
-    ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc)
+    ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
+    ("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+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';
+|]
+
+down_m20260823_snd_files_entitlement :: Text
+down_m20260823_snd_files_entitlement =
+  [r|
+ALTER TABLE snd_files DROP COLUMN storage_time;
+ALTER TABLE snd_files DROP COLUMN entitlement_credential;
+|]

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

@@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251230_strict_tables
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
 import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -99,7 +100,8 @@ schemaMigrations =
     ("m20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables),
     ("m20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts),
     ("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs),
-    ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc)
+    ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
+    ("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+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';
+  |]
+
+down_m20260823_snd_files_entitlement :: Query
+down_m20260823_snd_files_entitlement =
+  [sql|
+ALTER TABLE snd_files DROP COLUMN storage_time;
+ALTER TABLE snd_files DROP COLUMN entitlement_credential;
+  |]

src/Simplex/Messaging/Crypto/BBS.hs

@@ -33,6 +33,7 @@ import Data.Proxy (Proxy (..))
 import Foreign
 import Foreign.C
 import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
+import Simplex.Messaging.Encoding (Encoding (..), Large (..))
 import Simplex.Messaging.Encoding.String
 import System.IO.Unsafe (unsafePerformIO)
 
@@ -106,6 +107,10 @@ instance StrEncoding BBSProof where
       then pure (BBSProof bs)
       else fail $ "BBS: invalid proof length " <> show len
 
+instance Encoding BBSProof where
+  smpEncode (BBSProof p) = smpEncode (Large p)
+  smpP = (\(Large p) -> BBSProof p) <$> smpP
+
 -- FFI
 
 data BBS_Ciphersuite

src/Simplex/Messaging/Crypto/Entitlement.hs

@@ -34,7 +34,9 @@ import qualified Data.Map.Strict as M
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
+import Data.Word (Word16)
 import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON)
 
@@ -68,6 +70,21 @@ data EntitlementProof = EntitlementProof
   }
   deriving (Eq, Show)
 
+instance Encoding Entitlement where
+  smpEncode Entitlement {entitlementName, expiresAt, extraInfo} =
+    smpEncode (entitlementName, strEncode expiresAt, extraInfo)
+  smpP = do
+    (name, expBs, extra) <- smpP
+    expiresAt <- either fail pure $ strDecode (expBs :: ByteString)
+    pure Entitlement {entitlementName = name, expiresAt, extraInfo = extra}
+
+instance Encoding EntitlementProof where
+  smpEncode EntitlementProof {issuerKeyIdx, proof, entitlement} =
+    smpEncode (fromIntegral issuerKeyIdx :: Word16, proof, entitlement)
+  smpP = do
+    (idx, proof, entitlement) <- smpP
+    pure EntitlementProof {issuerKeyIdx = fromIntegral (idx :: Word16), proof, entitlement}
+
 entitlementBBSHeader :: BBSHeader
 entitlementBBSHeader = BBSHeader "SimpleX entitlement v1"
 

tests/AgentTests/SQLiteTests.hs

@@ -782,7 +782,7 @@ testGetNextSndFileToPrepare st = do
     -- Can't test it with strict tables
     -- Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     -- DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1"
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax
     DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"
 
     -- Left e <- getNextSndFileToPrepare db 86400
@@ -808,13 +808,13 @@ testGetNextSndChunkToUpload st = do
     Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400
 
     -- create file 1
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax
     updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     -- Can't test it with strict tables
     -- createSndFileReplica_ db 1 newSndChunkReplica1
     -- DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1"
     -- create file 2
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax
     updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     createSndFileReplica_ db 2 newSndChunkReplica1
 

tests/CoreTests/CryptoTests.hs

@@ -13,7 +13,10 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (isLeft, isRight)
 import Data.Int (Int64)
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..))
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LE
@@ -25,6 +28,7 @@ import qualified SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Crypto.Entitlement
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
 import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode)
@@ -119,6 +123,8 @@ cryptoTests = do
     it "should produce unlinkable proofs" testBBSUnlinkable
     it "should produce proof of expected size" testBBSProofSize
     it "should roundtrip JSON and reject wrong-length input" testBBSJSON
+  describe "Entitlement" $ do
+    it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip
 
 instance Eq C.APublicKey where
   C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of
@@ -444,3 +450,21 @@ testBBSJSON = do
   -- FromJSON must reject wrong-length input (regression: StrJSON length validation)
   (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing
   (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing
+
+testEntitlementRoundtrip :: IO ()
+testEntitlementRoundtrip = do
+  Right (pk, sk) <- bbsKeyGen
+  let keys = M.singleton 1 pk
+      mk = MasterKey (B.replicate 32 '\7')
+      ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""}
+      ph = BBSPresHeader "session-id + snd-key + digest"
+  Right cred <- signEntitlement sk 1 mk ent
+  verifyCredential pk cred `shouldReturn` True
+  Right proof <- generateEntitlementProof pk cred ph
+  verifyEntitlement keys ph proof `shouldReturn` Just True
+  -- a different presentation header does not verify (session/chunk binding)
+  verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` Just False
+  -- an unknown issuer key index yields Nothing
+  verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` Nothing
+  -- the protocol encoding of the proof roundtrips
+  smpDecode (smpEncode proof) `shouldBe` Right proof

tests/XFTPClient.hs

@@ -182,6 +182,7 @@ testXFTPServerConfig =
       controlPortAdminAuth = Nothing,
       controlPortUserAuth = Nothing,
       fileExpiration = Just defaultFileExpiration,
+      fileStorageEntitlements = mempty,
       fileTimeout = 10000000,
       inactiveClientExpiration = Just defaultInactiveClientExpiration,
       xftpCredentials =