fix header and test

update schema
add test of upload with entitlement
2026-08-30 07:38:44 +00:00 · 2026-08-28 11:44:05 +00:00 · 2026-08-28 12:43:30 +01:00 · 2026-08-28 10:17:42 +00:00 · 2026-08-28 07:24:13 +00:00 · 2026-08-27 20:36:09 +00:00
37 changed files with 822 additions and 180 deletions
@@ -58,7 +58,7 @@ xftpSubsts XFTPServerConfig {fileExpiration, logStatsInterval, allowNewFiles, ne
  [("smpConfig", Nothing), ("xftpConfig", Just "y")] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "file-server.ini")]
  where
    substConfig =
-      [ ("fileExpiration", Just $ maybe "Never" (fromString . timedTTLText . ttl) fileExpiration),
+      [ ("fileExpiration", Just . fromString . timedTTLText . ttl $ fileExpiration),
        ("statsEnabled", Just . yesNo $ isJust logStatsInterval),
        ("newUploadsAllowed", Just . yesNo $ allowNewFiles),
        ("basicAuthEnabled", Just . yesNo $ isJust newFileBasicAuth)
@@ -0,0 +1,144 @@
+# Implementation plan: XFTP variable file storage time
+
+Proposal: `../rfcs/2026-08-22-xftp-file-storage-time.md`.
+
+## simplexmq: entitlement crypto
+
+New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypto.BBS`:
+
+Types:
+
+```
+newtype MasterKey = MasterKey ByteString
+
+data Entitlement = Entitlement
+  { entitlementName :: Text,
+    expiresAt :: UTCTime,
+    extraInfo :: Text
+  }
+
+data EntitlementCredential = EntitlementCredential
+  { issuerKeyIdx :: Int,
+    masterKey :: MasterKey,
+    issuerSignature :: BBSSignature,
+    entitlement :: Entitlement
+  }
+
+data EntitlementProof = EntitlementProof
+  { issuerKeyIdx :: Int,
+    proof :: BBSProof,
+    entitlement :: Entitlement
+  }
+```
+
+Functions and constants:
+
+- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed
+- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes
+- `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)`
+- `verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it)
+- the issuer public keys constant `Map Int BBSPublicKey`
+
+## simplexmq: protocol, new XFTP version
+
+In `Simplex.FileTransfer.Transport`:
+
+- add the next `VersionXFTP` and set `currentXFTPVersion` to 4
+
+In `Simplex.FileTransfer.Protocol`:
+
+- add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants:
+
+```
+data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
+```
+
+- add the storage time (`Maybe Int64`: `Nothing` requests the server maximum, `Just` a number of hours) and `Maybe EntitlementProof` fields to `FNEW`
+- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version)
+- build the presentation header for FNEW
+
+In `Simplex.FileTransfer.Server`:
+
+- pass `sessionId` from `thParams` into `processXFTPRequest`
+
+## simplexmq: server configuration
+
+In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
+
+- make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds
+- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`; an absent key is skipped (that name gets the default), a present but malformed value fails startup
+- exit at startup if any name's maximum is below the default file expiration
+- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); `storageMaxSeconds` verifies the proof against it, so the trusted keys never come from the sender
+
+## simplexmq: server store and expiration
+
+The `files` table gets a nullable `expires_at`. Every new file stores a concrete `expires_at`. It is NULL only for pre-feature rows, which the migration must not re-date (it has no access to the operator's configured TTL); those are expired at query time as `created_at + ttl`.
+
+Common to both stores, in `Simplex.FileTransfer.Server.Store`:
+
+- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`
+- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, cap the requested hours at the entitlement's maximum, round the expiry up to the hour, store it, and return that same value as the granted storage
+- a valid proof raises the maximum to the entitlement's configured value; a proof that fails verification, carries an unknown issuer key, or whose entitlement expired more than 24 hours ago falls back to the default maximum. The entitlement is honoured for 24 hours after its `expiresAt`.
+- `expiredFiles` receives `now` and `old` (= `now - ttl`). A stored expiry is deleted when `expires_at < now` (no grace — it is already rounded up); a legacy row (no `expires_at`) is deleted when `created_at + fileTimePrecision < old` (the grace covers `created_at` being floored to the hour)
+- retain `created_at` for statistics, export, and the legacy fallback
+
+STM store:
+
+- in `expiredFiles`, expire a new file when `roundedSeconds expiresAt < now`, and a legacy file (no `expiresAt`) when `created_at + fileTimePrecision < old`
+
+PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations:
+
+- add the nullable column `expires_at BIGINT` (no backfill)
+- add one composite index `idx_files_expiry ON files (expires_at, created_at)`
+- `expiredFiles` query: `WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?` with `(now, old - fileTimePrecision)`. The first arm deletes stored (already rounded-up) expiries; the second drains legacy rows, with the grace folded into `old - fileTimePrecision` so the columns stay bare and sargable. Keep the `OR` at the top level so each disjunct is independently indexable (BitmapOr on the composite index): `expires_at` covers arm 1's range and arm 2's `IS NULL` group, and `created_at` orders arm 2 within that group. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order.
+
+Store log, in `Simplex.FileTransfer.Server.StoreLog`:
+
+- add the optional expiration to the `AddFile` record; a record without it parses to `Nothing` (the configured default), never a hardcoded value
+
+## simplexmq: agent
+
+Public API in `Simplex.Messaging.Agent`:
+
+- add `Maybe EntitlementCredential` and storage time (`Maybe Int64` hours) parameters to `xftpSendFile`
+
+Store, in both the SQLite and PostgreSQL agent stores:
+
+- add a nullable entitlement credential column (JSON text) and a nullable storage time column (integer hours; NULL means the server maximum) to `snd_files`
+- add the migration to both stores
+- in `createSndFile`, store the credential and the storage time
+
+Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`:
+
+- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant); `mkEntitlementProof` looks up `issuerKeyIdx` there to get the issuer public key that proof generation needs
+- in `agentXFTPNewChunk`, read the credential, the storage time, and the digest from the send record
+- inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof
+- `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica`
+
+Completion:
+
+- `createXFTPChunk` returns the granted expiry as `Maybe GrantedStorageTime`; `SndFileChunkReplica` and `NewSndChunkReplica` carry `expiresAt :: Maybe GrantedStorageTime`
+- persist it in a nullable `replica_expires_at` column on `snd_file_chunk_replicas` (added to the entitlement migration): `createSndFileReplica` stores `epochSeconds`, `getSndFile` reads it back into `GSTExpires`
+- on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord`
+- `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later)
+
+Testing:
+
+- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys`, send a file with the credential requesting a number of hours below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default)
+
+## simplex-chat
+
+- remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI
+- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent
+- pass the user's credential and `FSMaxTime` to `xftpSendFile`
+- retain the `maxXFTPFileSize` size limit
+- reuse `verifyEntitlement` for peer-badge verification
+- import the issuer public keys from the shared simplexmq constant
+
+## Order
+
+1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges.
+2. Add the new XFTP version, the FNEW protocol change (storage time + proof), and the response.
+3. Change the server configuration, store, expiration, and store log.
+4. Change the agent store and add proof generation on upload.
+5. Wire chat to pass the credential and the storage time.
@@ -0,0 +1,85 @@
+# XFTP variable file storage time
+
+## Summary
+
+The server stores a storage time for each file. The sender sets it in the FNEW command. The sender may present a proof of an entitlement to raise the maximum storage time the server allows. Each proof is bound to the uploaded chunk and to the TLS session, so it cannot be reused for another chunk or another session.
+
+## Entitlement
+
+An entitlement is a name, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entName` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send.
+
+The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here.
+
+```
+entitlement = entName entExpires entExtra
+entName = shortString        ; e.g. "supporter", "legend"
+entExpires = shortString     ; expiration as a UTCTime ISO8601 string
+entExtra = shortString       ; opaque, interpretation out of scope
+
+entitlementProof = issuerKeyIndex bbsProof entitlement
+issuerKeyIndex = 2*2 OCTET   ; Word16, network byte order
+bbsProof = largeString       ; BBS proof bytes
+```
+
+The presentation header that the BBS proof is generated over is not transmitted; the server reconstructs it from the command context (see [Binding](#binding)), which is what binds the proof.
+
+## Storage time
+
+```
+fileStorageTime = %s"0" / (%s"1" storageHours)
+storageHours = 8*8 OCTET     ; Int64, 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.
+
+## Commands, new XFTP version
+
+The new protocol version extends FNEW.
+
+```
+fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime optEntitlementProof
+optEntitlementProof = %s"0" / (%s"1" entitlementProof)
+```
+
+`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode neither `fileStorageTime` nor the proof, and the server applies the default storage time.
+
+## Responses
+
+FNEW extends the SIDS response with the granted storage.
+
+```
+sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime
+optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime)
+grantedStorageTime = grantedExpires
+grantedExpires = %s"T" expiresAt
+expiresAt = 8*8 OCTET        ; Int64, seconds since epoch (absolute UTC instant), network byte order
+```
+
+`grantedExpires` returns the absolute expiration — the same value stored for the file. The sum encoding retains a one-character prefix so further variants can be added. Version 3 and earlier omit `optGrantedStorageTime` entirely; a client decoding such a response reads it as absent. `senderId` and `rcvIds` are defined by the current XFTP protocol.
+
+## Binding
+
+The presentation header binds each proof to the TLS session and to the specific chunk. The server reconstructs it and rejects a proof generated for any other session or chunk.
+
+```
+presHeader = sessionId sndKey digest
+```
+
+The chunk is identified by the sender key and the digest, which the server verifies for every command on the file. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`.
+
+## Maximum storage time
+
+The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server honours an entitlement for 24 hours after its expiration; past that grace it is treated as no proof.
+
+If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. The expiration is rounded up to the hour, stored, and returned as `grantedExpires`.
+
+## Encoding primitives
+
+```
+shortString = length *OCTET   ; 0-255 bytes
+largeString = length2 *OCTET
+length = 1*1 OCTET
+length2 = 2*2 OCTET           ; Word16, network byte order
+```
+
+`senderId`, `rcvIds`, `fileInfo`, `sndKey`, `digest`, `rcvKeys`, `optBasicAuth`, and `sessionId` are defined by the current XFTP and SMP protocols.
@@ -135,6 +135,7 @@ library
      Simplex.Messaging.Crypto.Lazy
      Simplex.Messaging.Crypto.Ratchet
      Simplex.Messaging.Crypto.BBS
+      Simplex.Messaging.Crypto.Entitlement
      Simplex.Messaging.Crypto.SNTRUP761
      Simplex.Messaging.Crypto.SNTRUP761.Bindings
      Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
@@ -192,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
@@ -245,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:
@@ -54,7 +54,7 @@ import Simplex.FileTransfer.Chunks (toKB)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize)
 import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime, SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types
@@ -68,6 +68,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 +351,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 -> Maybe Int64 -> AM SndFileId
+xftpSendFile' c userId file numRecipients credential storageTime = do
  g <- asks random
  prefixPath <- lift $ getPrefixPath "snd.xftp"
  createDirectory prefixPath
@@ -359,7 +360,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 +376,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si
  liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
  key <- atomically $ C.randomSbKey g
  nonce <- atomically $ C.randomCbNonce g
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest}
+  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing Nothing
  lift . void $ getXFTPSndWorker True c Nothing
  pure fId

@@ -405,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} <-
+      SndFile {numRecipients, chunks, entitlementCredential, storageTime} <-
        if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
          then do
            fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
@@ -424,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'
+      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 +455,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 -> Maybe Int64 -> 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 +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
+                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth credential storageTime
                pure (replica, srvAuth)

 sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
@@ -543,7 +544,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
      notify c sndFileEntityId $ SFPROG uploaded total
      when complete $ do
        (sndDescr, rcvDescrs) <- sndFileToDescrs sf
-        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
+        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks)
        lift . forM_ prefixPath $ removePath <=< toFSFilePath
        withStore' c $ \db -> updateSndFileComplete db sndFileId
      where
@@ -577,6 +578,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
          let chunkSize = FileSize $ sndChunkSize ch
              replicas = [FileChunkReplica {server, replicaId, replicaKey}]
          pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
+        sndFileExpiresAt :: [SndFileChunk] -> Maybe GrantedStorageTime
+        sndFileExpiresAt = fmap minimum . mapM chunkExpiresAt
+          where
+            chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas)
        createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient]
        createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
          where
@@ -57,6 +57,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 (..),
@@ -253,10 +254,12 @@ createXFTPChunk ::
  FileInfo ->
  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)
+  Maybe Int64 ->
+  Maybe EntitlementProof ->
+  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime)
+createXFTPChunk c spKey file rcps auth_ storageTime proof =
+  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case
+    (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs)
    (r, _) -> throwE $ unexpectedResponse r

 addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
@@ -328,7 +328,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
          digest <- liftIO $ getChunkDigest chunkSpec
          let ch = FileInfo {sndKey, size = chunkSize, digest}
          c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
+          (sndId, rIds, _) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth Nothing Nothing
          withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
          logDebug $ "uploaded chunk " <> tshow chunkNo
          uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
@@ -22,6 +22,8 @@ module Simplex.FileTransfer.Protocol
    FileCommand (..),
    FileCmd (..),
    FileInfo (..),
+    GrantedStorageTime (..),
+    xftpNewProofHeader,
    XFTPFileId,
    FileResponse (..),
    xftpBlockSize,
@@ -38,14 +40,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 +82,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
@@ -175,7 +180,7 @@ 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 -> Maybe Int64 -> Maybe EntitlementProof -> FileCommand FSender
  FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
  FPUT :: FileCommand FSender
  FDEL :: FileCommand FSender
@@ -196,12 +201,30 @@ data FileInfo = FileInfo
  }
  deriving (Show)

+data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
+  deriving (Eq, Ord, Show)
+
+xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader
+xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest
+
+instance Encoding GrantedStorageTime where
+  smpEncode = \case
+    GSTExpires t -> smpEncode ('T', t)
+  smpP =
+    smpP >>= \case
+      'T' -> GSTExpires <$> smpP
+      _ -> fail "bad GrantedStorageTime"
+
 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 -> fnew <> e (st, ep)
+      | otherwise -> fnew
+      where
+        fnew = e (FNEW_, ' ', file, rKeys, auth_)
    FADD rKeys -> e (FADD_, ' ', rKeys)
    FPUT -> e FPUT_
    FDEL -> e FDEL_
@@ -235,10 +258,14 @@ 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 -> fnewP smpP smpP
+          | otherwise -> fnewP (pure Nothing) (pure Nothing)
+          where
+            fnewP stP epP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP <*> epP
        FADD_ -> FADD <$> _smpP
        FPUT_ -> pure FPUT
        FDEL_ -> pure FDEL
@@ -292,7 +319,7 @@ instance ProtocolMsgTag FileResponseTag where
    _ -> Nothing

 data FileResponse
-  = FRSndIds SenderId (NonEmpty RecipientId)
+  = FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime)
  | FRRcvIds (NonEmpty RecipientId)
  | FRFile RcvPublicDhKey C.CbNonce
  | FROk
@@ -303,7 +330,9 @@ 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)
    FROk -> e FROk_
@@ -315,8 +344,10 @@ 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 Nothing
    FRRcvIds_ -> FRRcvIds <$> _smpP
    FRFile_ -> FRFile <$> _smpP <*> smpP
    FROk_ -> pure FROk
@@ -30,11 +30,12 @@ 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
 import qualified Data.Text.IO as T
-import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+import Data.Time.Clock (UTCTime (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Data.X509 as X
@@ -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 (..), verifyEntitlement)
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -125,12 +128,12 @@ data Handshake

 xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
 xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
-  mapM_ (expireServerFiles Nothing) fileExpiration
+  expireServerFiles Nothing fileExpiration
  restoreServerStats
  raceAny_
    ( runServer
-        : expireFilesThread_ cfg
-          <> serverStatsThread_ cfg
+        : expireFiles fileExpiration
+        : serverStatsThread_ cfg
          <> prometheusMetricsThread_ cfg
          <> controlPortThread_ cfg
    )
@@ -243,10 +246,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
      saveServerStats
      logNote "Server stopped"

-    expireFilesThread_ :: XFTPServerConfig s -> [M s ()]
-    expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
-    expireFilesThread_ _ = []
-
    expireFiles :: ExpirationConfig -> M s ()
    expireFiles expCfg = do
      let interval = checkInterval expCfg * 1000000
@@ -401,9 +400,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 +442,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 +463,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
@@ -483,29 +482,44 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
  XFTPReqPing -> noFile FRPong
  where
    noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse
-    createFile file rks = do
+    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> Maybe EntitlementProof -> M s FileResponse
+    createFile file@FileInfo {sndKey, digest} rks storageTime ep = do
      st <- asks fileStore
      r <- runExceptT $ do
        sizes <- asks $ allowedChunkSizes . config
        unless (size file `elem` sizes) $ throwE SIZE
        ts <- liftIO getFileTime
+        now <- liftIO $ roundedSeconds <$> getSystemSeconds
+        maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep
+        let secs = maybe maxSeconds (\hours -> min (hours * 3600) maxSeconds) storageTime
+            fileExpiresAt = RoundedSystemTime $ ((now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
        -- TODO validate body empty
-        sId <- ExceptT $ addFileRetry st file 3 ts
+        sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
        rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
        lift $ withFileLog $ \sl -> do
-          logAddFile sl sId file ts EntityActive
+          logAddFile sl sId file ts (Just fileExpiresAt) EntityActive
          logAddRecipients sl sId rcps
        stats <- asks serverStats
        lift $ incFileStat filesCreated
        liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
        let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
-        pure $ FRSndIds sId rIds
+        pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt)))
      pure $ either FRErr id r
-    addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
-    addFileRetry st file n ts =
+    storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s Int64
+    storageMaxSeconds _ Nothing = asks $ ttl . fileExpiration . config
+    storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do
+      entCfg <- asks $ fileStorageEntitlements . config
+      keys <- asks $ entitlementKeys . config
+      defaultMax <- asks $ ttl . fileExpiration . config
+      now <- liftIO getCurrentTime
+      let Entitlement {entitlementName, expiresAt} = ent
+      liftIO (verifyEntitlement keys ph proof) >>= \case
+        Just True | addUTCTime nominalDay expiresAt > now -> pure $ fromMaybe defaultMax (M.lookup entitlementName entCfg)
+        _ -> pure defaultMax
+    addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
+    addFileRetry st file n ts expiresAt =
      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 =
@@ -648,16 +662,17 @@ expireServerFiles itemDelay expCfg = do
  st <- asks fileStore
  us <- asks usedStorage
  usedStart <- readTVarIO us
+  now <- liftIO $ roundedSeconds <$> getSystemSeconds
  old <- liftIO $ expireBeforeEpoch expCfg
  filesCount <- liftIO $ getFileCount st
  logNote $ "Expiration check: " <> tshow filesCount <> " files"
-  expireLoop st us old
+  expireLoop st us now old
  usedEnd <- readTVarIO us
  logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
  where
    mbs bs = tshow (bs `div` 1048576) <> "mb"
-    expireLoop st us old = do
-      expired <- liftIO $ expiredFiles st old 10000
+    expireLoop st us now old = do
+      expired <- liftIO $ expiredFiles st now old 10000
      forM_ expired $ \(sId, filePath_, fileSize) -> do
        mapM_ threadDelay itemDelay
        forM_ filePath_ $ \fp ->
@@ -670,7 +685,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 old

 randomId :: Int -> M s ByteString
 randomId n = atomically . C.randomBytes n =<< asks random
@@ -37,12 +37,17 @@ 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.Word (Word16, Word32)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
 import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.FileTransfer.Server.Stats
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
@@ -88,7 +93,10 @@ data XFTPServerConfig s = XFTPServerConfig
    controlPortUserAuth :: Maybe BasicAuth,
    controlPortAdminAuth :: Maybe BasicAuth,
    -- | time after which the files can be removed and check interval, seconds
-    fileExpiration :: Maybe ExpirationConfig,
+    fileExpiration :: ExpirationConfig,
+    -- | maximum storage time per entitlement name, seconds
+    fileStorageEntitlements :: Map Text Int64,
+    entitlementKeys :: Map Word16 BBSPublicKey,
    -- | timeout to receive file
    fileTimeout :: Int,
    -- | time after which inactive clients can be disconnected and check interval, seconds
@@ -171,7 +179,11 @@ defaultFileExpiration =
    }

 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 (>= 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) (Maybe Int64) (Maybe EntitlementProof)
  | XFTPReqCmd XFTPFileId FileRec FileCmd
  | XFTPReqPing

@@ -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
@@ -32,6 +35,7 @@ import Simplex.FileTransfer.Server (runXFTPServer)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, AFStoreType (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, readFileStoreType, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase)
 import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
@@ -239,9 +243,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
          putStrLn $ case storeLogFile of
            Just f -> "Store log: " <> f
            _ -> "Store log disabled."
-          putStrLn $ case fileExpiration of
-            Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
-            _ -> "not expiring files"
+          putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration)
          putStrLn $ case inactiveClientExpiration of
            Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
            _ -> "not expiring inactive clients"
@@ -287,10 +289,11 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
              controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
              controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
              fileExpiration =
-                Just
-                  defaultFileExpiration
-                    { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
-                    },
+                defaultFileExpiration
+                  { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
+                  },
+              fileStorageEntitlements = iniEntitlements ini,
+              entitlementKeys = entitlementIssuerKeys,
              fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
              inactiveClientExpiration =
                settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
@@ -437,3 +440,10 @@ 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 Int64
+iniEntitlements ini =
+  M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")]
+  where
+    readEntitlement (name, key) = (name,) . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini)
+    parseHours key t = maybe (error $ "Error: invalid " <> T.unpack key <> " value: " <> T.unpack t) (3600 *) (readMaybe (T.unpack (T.strip t)) :: Maybe Int64)
@@ -55,6 +55,7 @@ data FileRec = FileRec
    filePath :: TVar (Maybe FilePath),
    recipientIds :: TVar (Set RecipientId),
    createdAt :: RoundedFileTime,
+    expiresAt :: Maybe RoundedFileTime,
    fileStatus :: TVar ServerEntityStatus
  }

@@ -74,7 +75,7 @@ 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 ())
  addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
  deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ())
@@ -84,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 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
+  expiredFiles :: s -> Int64 -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
  getUsedStorage :: s -> IO Int64
  getFileCount :: s -> IO Int

@@ -107,9 +108,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 ()

@@ -166,14 +167,17 @@ instance FileStoreClass STMFileStore where
          pure $ Right ()
      _ -> pure $ Left AUTH

-  expiredFiles STMFileStore {files} old _limit = do
+  expiredFiles STMFileStore {files} now old _limit = do
    fs <- readTVarIO files
-    fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) ->
-      if createdAt + fileTimePrecision < old
-        then do
-          path <- readTVarIO filePath
-          pure $ Just (sId, path, size)
-        else pure Nothing
+    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
+            Nothing -> createdAt + fileTimePrecision < old
+       in if expired
+            then do
+              path <- readTVarIO filePath
+              pure $ Just (sId, path, size)
+            else pure Nothing

  getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files
    where
@@ -184,12 +188,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 =
@@ -82,17 +82,17 @@ 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 ->
@@ -131,13 +131,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 +152,12 @@ instance FileStoreClass PostgresFileStore where
      DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId)
    withLog "ackFile" st $ \s -> logAckFile s rId

-  expiredFiles st old limit =
+  expiredFiles st now old limit =
    fmap toResult $ withTransaction (dbStore st) $ \db ->
      DB.query
        db
-        "SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?"
-        (fileTimePrecision, old, limit)
+        "SELECT sender_id, file_path, file_size FROM files WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?"
+        (now, old - fileTimePrecision, limit)
    where
      toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
      toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))
@@ -174,21 +174,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 +243,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 +282,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 +326,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 +338,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)
      ]

@@ -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,17 @@ 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;
+CREATE INDEX idx_files_expiry ON files (expires_at, created_at);
+|]
+
+down_m20260823_file_expiration :: Text
+down_m20260823_file_expiration =
+  [r|
+DROP INDEX idx_files_expiry;
+ALTER TABLE files DROP COLUMN expires_at;
+|]
@@ -26,7 +26,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)
@@ -42,7 +42,7 @@ 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
@@ -52,27 +52,37 @@ data FileStoreLogRecord

 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) <> expE 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)
+    where
+      expE = maybe "" ((" " <>) . strEncode)
  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)
      ]
+    where
+      addFileP = do
+        sId <- strP_
+        file <- strP_
+        createdAt <- strP
+        status <- _strP <|> pure EntityActive
+        expiresAt <- (A.space *> (Just <$> strP)) <|> pure Nothing
+        pure $ AddFile sId file createdAt expiresAt status

 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

 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
@@ -102,8 +112,8 @@ 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
@@ -118,9 +128,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
@@ -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
@@ -29,16 +29,20 @@ 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 Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (GrantedStorageTime (..))
+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 +171,9 @@ data SndFile = SndFile
    prefixPath :: Maybe FilePath,
    status :: SndFileStatus,
    deleted :: Bool,
-    redirect :: Maybe RedirectFileInfo
+    redirect :: Maybe RedirectFileInfo,
+    entitlementCredential :: Maybe EntitlementCredential,
+    storageTime :: Maybe Int64
  }
  deriving (Show)

@@ -187,6 +193,10 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode

 instance ToField SndFileStatus where toField = toField . textEncode

+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
@@ -225,7 +235,8 @@ data NewSndChunkReplica = NewSndChunkReplica
  { server :: XFTPServer,
    replicaId :: ChunkReplicaId,
    replicaKey :: C.APrivateAuthKey,
-    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)]
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
+    expiresAt :: Maybe GrantedStorageTime
  }
  deriving (Show)

@@ -237,7 +248,8 @@ data SndFileChunkReplica = SndFileChunkReplica
    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
    replicaStatus :: SndFileReplicaStatus,
    delay :: Maybe Int64,
-    retries :: Int
+    retries :: Int,
+    expiresAt :: Maybe GrantedStorageTime
  }
  deriving (Show)

@@ -211,6 +211,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
@@ -773,8 +774,8 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
 {-# INLINE xftpDeleteRcvFiles #-}

 -- | Send XFTP file
-xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
-xftpSendFile c = withAgentEnv c .:. xftpSendFile' c
+xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId
+xftpSendFile c = withAgentEnv c .::. xftpSendFile' c
 {-# INLINE xftpSendFile #-}

 -- | Send XFTP file
@@ -233,7 +233,7 @@ import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
 import qualified Simplex.FileTransfer.Client as X
 import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb)
-import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse)
+import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, xftpNewProofHeader)
 import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion)
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..))
@@ -253,6 +253,7 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
 import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), generateEntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
@@ -1345,7 +1346,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
        let file = FileInfo {sndKey, size = chSize, digest}
            chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
        r <- runExceptT $ do
-          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
+          (sId, [rId], _) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth Nothing Nothing
          liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
          liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
          rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
@@ -2186,16 +2187,27 @@ 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 -> Maybe Int64 -> AM NewSndChunkReplica
+agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) credential storageTime = do
  rKeys <- xftpRcvKeys n
  (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
  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
+  keys <- asks $ entitlementKeys . config
+  (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> do
+    proof <- liftIO $ mkEntitlementProof keys (sessionId $ X.thParams xftp) sndKey
+    X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof
  logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
-  pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
+  pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt}
+  where
+    mkEntitlementProof keys sessId sndKey =
+      pure credential
+        $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys)
+        $>>= \pk -> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest)
+        >>= \case
+          Right p -> pure $ Just p
+          Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)

 agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
 agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
@@ -67,6 +67,8 @@ import Simplex.Messaging.Agent.Store.Interface (DBOpts)
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
+import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys)
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Notifications.Transport (NTFVersion)
@@ -148,6 +150,7 @@ data AgentConfig = AgentConfig
    smpCfg :: ProtocolClientConfig SMPVersion,
    ntfCfg :: ProtocolClientConfig NTFVersion,
    xftpCfg :: XFTPClientConfig,
+    entitlementKeys :: Map Word16 BBSPublicKey,
    reconnectInterval :: RetryInterval,
    messageRetryInterval :: RetryInterval2,
    userNetworkInterval :: Int,
@@ -226,6 +229,7 @@ defaultAgentConfig =
      smpCfg = defaultSMPClientConfig,
      ntfCfg = defaultNTFClientConfig,
      xftpCfg = defaultXFTPClientConfig,
+      entitlementKeys = entitlementIssuerKeys,
      reconnectInterval = defaultReconnectInterval,
      messageRetryInterval = defaultMessageRetryInterval,
      userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value
@@ -228,7 +228,7 @@ import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word32)
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime)
 import Simplex.FileTransfer.Transport (XFTPErrorType)
 import Simplex.FileTransfer.Types (FileErrorType)
 import Simplex.Messaging.Agent.QueryString
@@ -444,7 +444,7 @@ data AEvent (e :: AEntity) where
  RFERR :: AgentErrorType -> AEvent AERcvFile
  RFWARN :: AgentErrorType -> AEvent AERcvFile
  SFPROG :: Int64 -> Int64 -> AEvent AESndFile
-  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent AESndFile
+  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> Maybe GrantedStorageTime -> AEvent AESndFile
  SFERR :: AgentErrorType -> AEvent AESndFile
  SFWARN :: AgentErrorType -> AEvent AESndFile

@@ -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 (..), GrantedStorageTime (..), 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 -> Maybe Int64 -> IO (Either StoreError SndFileId)
+createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime =
  createWithRandomId db gVar $ \sndFileEntityId ->
    DB.execute
      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, Maybe Int64) -> SndFile
+        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) =
          let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
              srcFile = CryptoFile srcPath cfArgs
              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 <-
@@ -3510,7 +3511,7 @@ getSndFile db sndFileId = runExceptT $ do
            db
            [sql|
              SELECT
-                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries,
+                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at,
                s.xftp_host, s.xftp_port, s.xftp_key_hash
              FROM snd_file_chunk_replicas r
              JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
@@ -3521,10 +3522,10 @@ getSndFile db sndFileId = runExceptT $ do
        rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
        pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
      where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
-        toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) =
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
+        toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec, host, port, keyHash) =
          let server = XFTPServer host port keyHash
-           in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}
+           in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}

 getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)]
 getChunkReplicaRecipients_ db replicaId =
@@ -3605,16 +3606,16 @@ createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> I
 createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId

 createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO ()
-createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
+createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys, expiresAt} = do
  srvId <- createXFTPServer_ db server
  DB.execute
    db
    [sql|
      INSERT INTO snd_file_chunk_replicas
-        (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status)
-      VALUES (?,?,?,?,?,?)
+        (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status, replica_expires_at)
+      VALUES (?,?,?,?,?,?,?)
    |]
-    (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated)
+    (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated, epochSeconds <$> expiresAt)
  rId <- insertedRowId db
  forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do
    DB.execute
@@ -3687,7 +3688,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
                  chunkSpec,
                  digest,
                  filePrefixPath,
-                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}]
+                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = Nothing, rcvIdsKeys = []}]
                }

 updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
@@ -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
@@ -0,0 +1,23 @@
+{-# 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 BIGINT;
+ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at BIGINT;
+|]
+
+down_m20260823_snd_files_entitlement :: Text
+down_m20260823_snd_files_entitlement =
+  [r|
+ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at;
+ALTER TABLE snd_files DROP COLUMN storage_time;
+ALTER TABLE snd_files DROP COLUMN entitlement_credential;
+|]
@@ -741,7 +741,9 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_files (
    src_file_nonce bytea,
    failed smallint DEFAULT 0,
    redirect_size bigint,
-    redirect_digest bytea
+    redirect_digest bytea,
+    entitlement_credential text,
+    storage_time bigint
 );


@@ -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
@@ -0,0 +1,22 @@
+{-# 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 INTEGER;
+ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at INTEGER;
+  |]
+
+down_m20260823_snd_files_entitlement :: Query
+down_m20260823_snd_files_entitlement =
+  [sql|
+ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at;
+ALTER TABLE snd_files DROP COLUMN storage_time;
+ALTER TABLE snd_files DROP COLUMN entitlement_credential;
+  |]
@@ -352,7 +352,9 @@ CREATE TABLE snd_files(
  src_file_nonce BLOB,
  failed INTEGER DEFAULT 0,
  redirect_size INTEGER,
-  redirect_digest BLOB
+  redirect_digest BLOB,
+  entitlement_credential TEXT,
+  storage_time INTEGER
 ) STRICT;
 CREATE TABLE snd_file_chunks(
  snd_file_chunk_id INTEGER PRIMARY KEY,
@@ -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 = BBSProof . unLarge <$> smpP
+
 -- FFI

 data BBS_Ciphersuite
@@ -0,0 +1,134 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Messaging.Crypto.Entitlement
+  ( Entitlement (..),
+    EntitlementCredential (..),
+    EntitlementProof (..),
+    MasterKey (..),
+    entitlementBBSHeader,
+    entitlementIssuerKeys,
+    signEntitlement,
+    verifyCredential,
+    generateEntitlementProof,
+    verifyEntitlement,
+  )
+where
+
+import Control.Monad (forM)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.TH as JQ
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Map.Strict (Map)
+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)
+import Simplex.Messaging.Util ((<$$>))
+
+newtype MasterKey = MasterKey ByteString
+  deriving newtype (Eq, Show, StrEncoding)
+  deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey)
+
+data Entitlement = Entitlement
+  { entitlementName :: Text,
+    expiresAt :: UTCTime,
+    extraInfo :: Text
+  }
+  deriving (Eq, Show)
+
+data EntitlementCredential = EntitlementCredential
+  { issuerKeyIdx :: Word16,
+    masterKey :: MasterKey,
+    entitlement :: Entitlement,
+    issuerSignature :: BBSSignature
+  }
+  deriving (Eq, Show)
+
+data EntitlementProof = EntitlementProof
+  { issuerKeyIdx :: Word16,
+    entitlement :: Entitlement,
+    entProof :: BBSProof
+  }
+  deriving (Eq, Show)
+
+instance Encoding Entitlement where
+  smpEncode Entitlement {entitlementName, expiresAt, extraInfo} =
+    smpEncode (entitlementName, strEncode expiresAt, extraInfo)
+  smpP = do
+    (entitlementName, expBs, extraInfo) <- smpP
+    expiresAt <- either fail pure $ strDecode (expBs :: ByteString)
+    pure Entitlement {entitlementName, expiresAt, extraInfo}
+
+instance Encoding EntitlementProof where
+  smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} =
+    smpEncode (issuerKeyIdx, entProof, entitlement)
+  smpP = do
+    (issuerKeyIdx, entProof, entitlement) <- smpP
+    pure EntitlementProof {issuerKeyIdx, entProof, entitlement}
+
+entitlementBBSHeader :: BBSHeader
+entitlementBBSHeader = BBSHeader "SimpleX badges v1"
+
+entitlementMessageCount :: Int
+entitlementMessageCount = 4
+
+entitlementDisclosedIndexes :: [Int]
+entitlementDisclosedIndexes = [1, 2, 3]
+
+entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
+entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent
+
+disclosedMessages :: Entitlement -> [ByteString]
+disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} =
+  [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo]
+
+signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential)
+signEntitlement sk keyIdx mk ent =
+  EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent)
+
+verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool
+verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} =
+  bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement)
+
+generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
+generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
+  EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
+
+verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)
+verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} =
+  forM (M.lookup issuerKeyIdx keys) $ \pk ->
+    bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
+
+entitlementIssuerKeys :: Map Word16 BBSPublicKey
+entitlementIssuerKeys =
+  M.fromList
+    [ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"),
+      (2, key "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"),
+      (3, key "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"),
+      (4, key "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"),
+      (5, key "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"),
+      (6, key "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"),
+      (7, key "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
+      (8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
+    ]
+  where
+    key = fromRight (error "bad base64 in BBSPublicKey") . strDecode . B.pack
+
+$(JQ.deriveJSON defaultJSON ''Entitlement)
+
+$(JQ.deriveJSON defaultJSON ''EntitlementCredential)
+
+$(JQ.deriveJSON defaultJSON ''EntitlementProof)
@@ -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 Nothing
    DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"

    -- Left e <- getNextSndFileToPrepare db 86400
@@ -798,7 +798,8 @@ newSndChunkReplica1 =
    { server = xftpServer1,
      replicaId = ChunkReplicaId $ EntityId "abc",
      replicaKey = testFileReplicaKey,
-      rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)]
+      rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)],
+      expiresAt = Nothing
    }

 testGetNextSndChunkToUpload :: DBStore -> Expectation
@@ -808,13 +809,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 Nothing
    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 Nothing
    updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
    createSndFileReplica_ db 2 newSndChunkReplica1

@@ -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
@@ -75,7 +75,7 @@ testAddGetFileSender = withPgStore $ \st -> do
  g <- C.newRandom
  (sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sk
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  result <- getFile st SFSender testSenderId
  case result of
    Right (FileRec {senderId, fileInfo = fi, createdAt}, key) -> do
@@ -92,7 +92,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
  result <- getFile st SFRecipient testRecipientId
  case result of
@@ -106,8 +106,8 @@ testDuplicateFile = withPgStore $ \st -> do
  g <- C.newRandom
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Left DUPLICATE_
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_

 testGetNonexistent :: Expectation
 testGetNonexistent = withPgStore $ \st -> do
@@ -119,7 +119,7 @@ testSetFilePath = withPgStore $ \st -> do
  g <- C.newRandom
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  setFilePath st testSenderId "/tmp/test_file" `shouldReturn` Right ()
  -- Second setFilePath should fail (file_path IS NULL guard)
  setFilePath st testSenderId "/tmp/other_file" `shouldReturn` Left AUTH
@@ -135,7 +135,7 @@ testDuplicateRecipient = withPgStore $ \st -> do
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
  addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_

@@ -145,7 +145,7 @@ testDeleteFileCascade = withPgStore $ \st -> do
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
  deleteFile st testSenderId `shouldReturn` Right ()
  -- File and recipient should both be gone
@@ -157,7 +157,7 @@ testBlockFile = withPgStore $ \st -> do
  g <- C.newRandom
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  let blockInfo = BlockingInfo {reason = BRContent, notice = Nothing}
  blockFile st testSenderId blockInfo False `shouldReturn` Right ()
  result <- getFile st SFSender testSenderId
@@ -171,7 +171,7 @@ testAckFile = withPgStore $ \st -> do
  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
  let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
  ackFile st testRecipientId `shouldReturn` Right ()
  -- Recipient gone, but file still exists
@@ -189,11 +189,11 @@ testExpiredFiles = withPgStore $ \st -> do
      oldTime = RoundedSystemTime 100000
      newTime = RoundedSystemTime 999999999
  -- Add old and new files
-  addFile st (EntityId "old_file________") fileInfo oldTime EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "old_file________") fileInfo oldTime Nothing EntityActive `shouldReturn` Right ()
  void $ setFilePath st (EntityId "old_file________") "/tmp/old"
-  addFile st (EntityId "new_file________") fileInfo newTime EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right ()
  -- Query expired with cutoff that only catches old file
-  expired <- expiredFiles st 500000 100
+  expired <- expiredFiles st 500000 500000 100
  length expired `shouldBe` 1
  case expired of
    [(sId, path, sz)] -> do
@@ -222,8 +222,8 @@ testStorageAndCountForStore st = do
      fileInfoB = fileInfoA {size = 64000}
      fileA = EntityId "file_a__________"
      fileB = EntityId "file_b__________"
-  addFile st fileA fileInfoA testCreatedAt EntityActive `shouldReturn` Right ()
-  addFile st fileB fileInfoB testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st fileA fileInfoA testCreatedAt Nothing EntityActive `shouldReturn` Right ()
+  addFile st fileB fileInfoB testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  getFileCount st `shouldReturn` 2
  getUsedStorage st `shouldReturn` 0
  setFilePath st fileA "/tmp/file_a" `shouldReturn` Right ()
@@ -248,11 +248,11 @@ testMigrationRoundTrip = do
      sId1 = EntityId "migration_file_1"
      sId2 = EntityId "migration_file_2"
      rId1 = EntityId "migration_rcp_1_"
-  addFile stmStore sId1 fileInfo1 testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile stmStore sId1 fileInfo1 testCreatedAt Nothing EntityActive `shouldReturn` Right ()
  void $ setFilePath stmStore sId1 "/tmp/file1"
  addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right ()
  let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing}
-  addFile stmStore sId2 fileInfo2 testCreatedAt (EntityBlocked testBlockInfo) `shouldReturn` Right ()
+  addFile stmStore sId2 fileInfo2 testCreatedAt Nothing (EntityBlocked testBlockInfo) `shouldReturn` Right ()
  -- 2. Write to StoreLog
  sl <- openWriteStoreLog False storeLogPath
  writeFileStore sl stmStore
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -20,22 +21,30 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
 import Data.Int (Int64)
 import Data.List (find, isSuffixOf)
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromJust)
+import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.System (getSystemTime, systemSeconds)
 import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3)
 import SMPClient (xit'')
 import Simplex.FileTransfer.Client (XFTPClientConfig (..))
 import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..))
 import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
 import Simplex.FileTransfer.Server.Store (STMFileStore)
 import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
-import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
+import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers)
+import qualified Simplex.Messaging.Agent as XA
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
-import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
+import qualified Simplex.Messaging.Agent.Env.SQLite as AEnv
+import Simplex.Messaging.Agent.Protocol hiding (SFDONE)
+import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Client (pattern NRMInteractive)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (bbsKeyGen)
+import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), signEntitlement)
 import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -56,6 +65,9 @@ import Fixtures
 import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
 #endif

+pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile
+pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _
+
 xftpAgentTests :: SpecWith AFStoreType
 xftpAgentTests =
  around_ testBracket
@@ -71,6 +83,7 @@ xftpAgentTests =
      it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
      it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect
      it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect
+      it "should extend storage time with an entitlement proof and report the granted expiry" $ \_ -> testXFTPAgentEntitlement
      describe "sending and receiving with version negotiation" $ beforeWith (const (pure ())) testXFTPAgentSendReceiveMatrix
      it "should resume receiving file after restart" $ \_ -> testXFTPAgentReceiveRestore
      it "should cleanup rcv tmp path after permanent error" $ \_ -> testXFTPAgentReceiveCleanup
@@ -326,6 +339,32 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO ()
 testNoRedundancy (ValidFileDescription FileDescription {chunks}) =
  all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True

+testXFTPAgentEntitlement :: HasCallStack => IO ()
+testXFTPAgentEntitlement = do
+  Right (issuerPk, issuerSk) <- bbsKeyGen
+  now <- getCurrentTime
+  let ent = Entitlement {entitlementName = "supporter", expiresAt = addUTCTime (30 * nominalDay) now, extraInfo = ""}
+      keys = M.fromList [(1, issuerPk)]
+  Right credential <- signEntitlement issuerSk 1 (MasterKey "0123456789abcdef0123456789abcdef") ent
+  let srvCfg = testXFTPServerConfig {entitlementKeys = keys, fileStorageEntitlements = M.fromList [("supporter", 168 * 3600)]}
+  withXFTPServerCfg srvCfg $ \_ -> do
+    filePath <- createRandomFile_ (kb 128 :: Integer) "testfile"
+    withAgent 1 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB $ \sndr -> runRight_ $ do
+      xftpStartWorkers sndr (Just senderFiles)
+      nowSec <- liftIO $ systemSeconds <$> getSystemTime
+      _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just credential) (Just 100)
+      gExpires <- waitSndDone sndr
+      liftIO $ case gExpires of
+        Just (GSTExpires t) -> do
+          t `shouldSatisfy` (>= nowSec + 100 * 3600)
+          t `shouldSatisfy` (< nowSec + 100 * 3600 + 7200)
+        Nothing -> expectationFailure "expected granted storage time in SFDONE"
+  where
+    waitSndDone sndr =
+      sfGet sndr >>= \case
+        ("", _, A.SFDONE _ _ g) -> pure g
+        _ -> waitSndDone sndr
+
 testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
 testReceive rcp rfd = testReceiveCF rcp rfd Nothing

@@ -619,7 +658,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te

 testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO ()
 testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
-  withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = Just fastExpiration}) . const $ do
+  withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do
    filePath1 <- createRandomFile' "testfile1"

    -- send file 1
@@ -19,6 +19,7 @@ import Simplex.FileTransfer.Server (runXFTPServerBlocking)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), AFStoreType (..), defaultFileExpiration, defaultInactiveClientExpiration)
 import Simplex.FileTransfer.Server.Store (FileStoreClass, SFSType (..), STMFileStore)
 import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
+import qualified Simplex.Messaging.Agent as A
 import Simplex.Messaging.Protocol (XFTPServer)
 import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server
@@ -32,6 +33,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 #endif

+xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing Nothing
+
 data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s)

 updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig
@@ -181,7 +184,9 @@ testXFTPServerConfig =
      newFileBasicAuth = Nothing,
      controlPortAdminAuth = Nothing,
      controlPortUserAuth = Nothing,
-      fileExpiration = Just defaultFileExpiration,
+      fileExpiration = defaultFileExpiration,
+      fileStorageEntitlements = mempty,
+      entitlementKeys = mempty,
      fileTimeout = 10000000,
      inactiveClientExpiration = Just defaultInactiveClientExpiration,
      xftpCredentials =
@@ -28,7 +28,8 @@ import Data.X509.Validation (Fingerprint (..), getFingerprint)
 import Network.HPACK.Token (tokenKey)
 import qualified Network.HTTP2.Client as H2
 import ServerTests (logSize)
-import Simplex.FileTransfer.Client
+import Simplex.FileTransfer.Client hiding (createXFTPChunk)
+import qualified Simplex.FileTransfer.Client as A
 import Simplex.FileTransfer.Description (kb)
 import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId, xftpBlockSize)
 import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
@@ -37,7 +38,8 @@ import Simplex.Messaging.Client (ProtocolClientError (..))
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding (smpDecode, smpEncode)
-import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
+import Data.List.NonEmpty (NonEmpty)
+import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), RecipientId, SenderId, pattern NoEntity)
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import Simplex.Messaging.Transport (CertChainPubKey (..), TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient)
@@ -100,6 +102,9 @@ createTestChunk fp = do
  B.writeFile fp bytes
  pure bytes

+createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
+createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing Nothing
+
 readChunk :: XFTPFileId -> IO ByteString
 readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))

@@ -240,7 +245,7 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs
    deleteXFTPChunk c spKey sId
      `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
  where
-    fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
+    fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1}

 testInactiveClientExpiration :: AFStoreType -> Expectation
 testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do
@@ -46,10 +46,11 @@ import Test.Hspec hiding (fit, it)
 import Util
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig)
 import Simplex.FileTransfer.Server.Store (STMFileStore)
-import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort)
+import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpSendFile, xftpTestPort)
 import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent)
-import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
-import Simplex.Messaging.Agent.Protocol (AEvent (..))
+import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers)
+import Simplex.Messaging.Agent.Protocol hiding (SFDONE)
+import qualified Simplex.Messaging.Agent.Protocol as A
 import SMPAgentClient (agentCfg, initAgentServers, testDB)
 import XFTPCLI (recipientFiles, senderFiles, testBracket)
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -168,6 +169,9 @@ impAddr = "import * as Addr from './dist/protocol/address.js';"
 jsOut :: String -> String
 jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));"

+pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile
+pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _
+
 xftpWebTests :: IO () -> Spec
 xftpWebTests dbCleanup = do
  xftpWebSourceHygieneTests
Author	SHA1	Message	Date
Evgeny @ SimpleX Chat	6541745fca	fix header and test	2026-08-28 11:44:05 +00:00
Evgeny Poberezkin	173916bca3	update schema	2026-08-28 12:43:30 +01:00
Evgeny @ SimpleX Chat	f064513177	add test of upload with entitlement	2026-08-28 10:17:42 +00:00
Evgeny @ SimpleX Chat	1ce2df9aa0	add file expiration time to agent event	2026-08-28 07:24:13 +00:00
Evgeny @ SimpleX Chat	af4bed8836	remove comments	2026-08-27 20:36:09 +00:00
Evgeny Poberezkin	8a998a7cf7	simpler	2026-08-27 21:30:09 +01:00
Evgeny Poberezkin	46bb52db6a	simplify	2026-08-27 21:18:29 +01:00
Evgeny Poberezkin	121628a39b	simplify	2026-08-27 21:07:44 +01:00
Evgeny @ SimpleX Chat	3aad156114	refactor	2026-08-27 20:00:26 +00:00
Evgeny @ SimpleX Chat	83accac0bb	refactor	2026-08-27 19:19:50 +00:00
Evgeny @ SimpleX Chat	9507b2d6ea	refactor	2026-08-27 18:41:56 +00:00
Evgeny @ SimpleX Chat	ed9786af1c	remove permanent and FTTL	2026-08-27 12:19:23 +00:00
Evgeny @ SimpleX Chat	fddc151ae0	update	2026-08-26 10:41:32 +00:00
Evgeny @ SimpleX Chat	c08946214d	implementation	2026-08-24 20:52:57 +00:00
Evgeny @ SimpleX Chat	0df161a002	types	2026-08-23 15:15:37 +00:00
Evgeny @ SimpleX Chat	add65420c7	update	2026-08-22 22:37:57 +00:00
Evgeny @ SimpleX Chat	4989bd8df6	xftp server: support storage time and BBS proofs of badge credential to extend it	2026-08-22 21:47:38 +00:00