update

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

@@ -71,10 +71,10 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
 
 In `Simplex.FileTransfer.Server`:
 
-- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name
-- verify only when the answer can change: the name is configured with a maximum above the default, and the entitlement expired less than 24 hours ago. A proof that fails these checks or fails to verify is logged, and the session gets the default maximum
+- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. It takes the resolution as a parameter: the first handshake verifies, a repeated handshake with the `xftp-handshake` header keeps the entitlement of the session and verifies nothing
+- verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum
 - a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed
-- `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid and above the default, and the default otherwise
+- `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise
 
 ## simplexmq: server store and expiration
 

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

@@ -51,7 +51,7 @@ optEntitlementProof = %s"0" / (%s"1" entitlementProof)
 
 `xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof.
 
-The server verifies the proof once, when it accepts the handshake, and keeps the resulting maximum storage time for the session. A proof that fails to verify, names an entitlement the server does not configure, or names one whose expiration passed more than 24 hours ago, is logged and ignored, and the session gets the default maximum. The client learns nothing about which entitlements the server accepts.
+The server verifies the proof when it accepts the handshake and keeps the result for the session; a repeated handshake carrying the `xftp-handshake` header keeps that result and verifies nothing. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures.
 
 ## Commands
 
@@ -89,6 +89,8 @@ presHeader = sessionId
 
 Binding to the session is what stops a proof being replayed by another client. A proof is not bound to a file, because the entitlement belongs to the user and authorises everything the client does in that session.
 
+BBS proofs of one credential are unlinkable, but every proof discloses the same `entExpires`, `entName` and `entExtra`, so a server can link the sessions of one holder by that triple, and two servers can correlate them. The issuing service decides how identifying it is: `entExpires` set to the same instant for everyone who buys in the same period, and an `entExtra` that carries nothing per-holder, make the holders of that period indistinguishable.
+
 ## 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.

src/Simplex/FileTransfer/Server.hs

@@ -180,10 +180,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           | otherwise -> processHello Nothing
         Just (HandshakeSent pk)
           | webHello -> processHello (Just pk)
-          | otherwise -> processClientHandshake pk
+          | otherwise -> processClientHandshake pk verifiedEntitlement
         Just (HandshakeAccepted thParams)
           | webHello -> processHello (serverPrivKey <$> thAuth thParams)
-          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth)
+          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (const . pure $ peerEntitlement auth)
           | otherwise -> pure $ Just thParams
       either sendError pure r
       where
@@ -213,7 +213,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
 #endif
           liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs
           pure Nothing
-        processClientHandshake pk = do
+        processClientHandshake pk sessionEntitlement = do
           unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE
           body <- liftHS $ C.unPad bodyHead
           XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body
@@ -221,7 +221,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
           unless (keyHash == kh) $ throwE HANDSHAKE
           case compatibleVRange' xftpServerVRange v of
             Just (Compatible vr) -> do
-              ent <- lift $ verifiedEntitlement entitlementProof
+              ent <- lift $ sessionEntitlement entitlementProof
               let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing}
                   thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
               atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions

src/Simplex/FileTransfer/Server/Main.hs

@@ -19,10 +19,10 @@ import Data.Either (fromRight)
 import Data.Functor (($>))
 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.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text as T

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -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)
@@ -82,7 +82,7 @@ logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
 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
+logAddFile s = logFileStoreRecord s .::. AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile

src/Simplex/FileTransfer/Types.hs

@@ -29,20 +29,17 @@ 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 (decodeUtf8, encodeUtf8)
+import Data.Text.Encoding (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 (..))
@@ -192,10 +189,6 @@ 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

src/Simplex/Messaging/Agent/Client.hs

@@ -1053,12 +1053,10 @@ reconnectSMPServer c userId srv = do
 
 closeUserXFTPClients :: AgentClient -> UserId -> IO ()
 closeUserXFTPClients c userId = do
-  cs <- readTVarIO $ xftpClients c
-  mapM_ (forkIO . closeClient_ c) $ M.foldrWithKey userClient [] cs
-  where
-    userClient (userId', _, _) v
-      | userId == userId' = (v :)
-      | otherwise = id
+  vs <- atomically $ stateTVar (xftpClients c) $ \cs ->
+    let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs
+     in (M.elems userCs, cs')
+  mapM_ (forkIO . closeClient_ c) vs
 
 closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
 closeClient c clientSel tSess =

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql

@@ -682,7 +682,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_file_chunk_replicas (
     delay bigint,
     retries bigint DEFAULT 0 NOT NULL,
     created_at timestamp with time zone DEFAULT now() NOT NULL,
-    updated_at timestamp with time zone DEFAULT now() NOT NULL
+    updated_at timestamp with time zone DEFAULT now() NOT NULL,
+    replica_expires_at bigint
 );
 
 

src/Simplex/Messaging/Crypto/Entitlement.hs

@@ -95,7 +95,7 @@ entitlementMessageCount :: Int
 entitlementMessageCount = 4
 
 entitlementDisclosedIndexes :: [Int]
-entitlementDisclosedIndexes = [1, 2, 3]
+entitlementDisclosedIndexes = [1 .. entitlementMessageCount - 1]
 
 entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
 entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent

tests/CoreTests/CryptoTests.hs

@@ -16,9 +16,9 @@ import Data.Either (isLeft, isRight)
 import Data.Int (Int64)
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
 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
 import Data.Type.Equality

tests/CoreTests/StoreLogTests.hs

@@ -244,6 +244,12 @@ fileStoreLogTests = do
           saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice],
           compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)],
           state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))]
+        },
+      SLTC
+        { name = "block file without expiration",
+          saved = [AddFile sId file createdAt Nothing EntityActive, BlockFile sId blockedWithNotice],
+          compacted = [AddFile sId file createdAt Nothing (EntityBlocked blockedWithNotice)],
+          state = M.fromList [(sId, (file, createdAt, Nothing, EntityBlocked blockedWithNotice))]
         }
     ]
 

tests/CoreTests/XFTPStoreTests.hs

@@ -37,6 +37,7 @@ xftpStoreTests = do
     it "should block file and update status" testBlockFile
     it "should ack file reception" testAckFile
     it "should return expired files with limit" testExpiredFiles
+    it "should expire files by stored expiration" testExpiredFilesStoredExpiration
     it "should compute committed used storage and file count" testStorageAndCount
 
 xftpMigrationTests :: Spec
@@ -68,6 +69,9 @@ testFileInfo sndKey =
 testCreatedAt :: RoundedFileTime
 testCreatedAt = RoundedSystemTime 1000000
 
+testExpiresAt :: RoundedFileTime
+testExpiresAt = RoundedSystemTime 2000000
+
 -- Tests
 
 testAddGetFileSender :: Expectation
@@ -202,6 +206,18 @@ testExpiredFiles = withPgStore $ \st -> do
       sz `shouldBe` 128000
     _ -> expectationFailure "expected 1 expired file"
 
+testExpiredFilesStoredExpiration :: Expectation
+testExpiredFilesStoredExpiration = withPgStore $ \st -> do
+  g <- C.newRandom
+  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  let fileInfo = testFileInfo sndKey
+      oldTime = RoundedSystemTime 100000
+  -- both files are created before the cutoff, the stored expiration decides
+  addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
+  expired <- expiredFiles st 500000 0 100
+  map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
+
 testStorageAndCount :: Expectation
 testStorageAndCount = withPgStore $ \st -> do
   testStorageAndCountForStore st
@@ -248,7 +264,7 @@ testMigrationRoundTrip = do
       sId1 = EntityId "migration_file_1"
       sId2 = EntityId "migration_file_2"
       rId1 = EntityId "migration_rcp_1_"
-  addFile stmStore sId1 fileInfo1 testCreatedAt Nothing EntityActive `shouldReturn` Right ()
+  addFile stmStore sId1 fileInfo1 testCreatedAt (Just testExpiresAt) EntityActive `shouldReturn` Right ()
   void $ setFilePath stmStore sId1 "/tmp/file1"
   addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right ()
   let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing}
@@ -271,9 +287,10 @@ testMigrationRoundTrip = do
   -- Verify file 1
   result1 <- getFile stmStore2 SFSender sId1
   case result1 of
-    Right (FileRec {fileInfo = fi, filePath, fileStatus}, _) -> do
+    Right (FileRec {fileInfo = fi, filePath, expiresAt, fileStatus}, _) -> do
       size fi `shouldBe` 128000
       readTVarIO filePath `shouldReturn` Just "/tmp/file1"
+      expiresAt `shouldBe` Just testExpiresAt
       readTVarIO fileStatus `shouldReturn` EntityActive
     Left e -> expectationFailure $ "getFile sId1 failed: " <> show e
   -- Verify recipient

tests/XFTPAgent.hs

@@ -30,7 +30,7 @@ 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 (..), GrantedStorageTime (..))
-import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
+import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..), defaultFileExpiration)
 import Simplex.FileTransfer.Server.Store (STMFileStore)
 import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
@@ -356,16 +356,26 @@ testXFTPAgentEntitlement = do
       nowSec <- liftIO $ systemSeconds <$> getSystemTime
       _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (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"
+      liftIO $ expiresIn gExpires nowSec (100 * 3600)
+    -- the same request without the credential is capped at the default maximum
+    withAgent 2 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB2 $ \sndr -> runRight_ $ do
+      xftpStartWorkers sndr (Just senderFiles)
+      nowSec <- liftIO $ systemSeconds <$> getSystemTime
+      _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just 100)
+      gExpires <- waitSndDone sndr
+      let ExpirationConfig {ttl} = defaultFileExpiration
+      liftIO $ expiresIn gExpires nowSec ttl
   where
+    expiresIn gExpires nowSec secs = case gExpires of
+      Just (GSTExpires t) -> do
+        t `shouldSatisfy` (>= nowSec + secs)
+        t `shouldSatisfy` (< nowSec + secs + 7200)
+      Nothing -> expectationFailure "expected granted storage time in SFDONE"
     waitSndDone sndr =
       sfGet sndr >>= \case
         ("", _, A.SFDONE _ _ g) -> pure g
-        _ -> waitSndDone sndr
+        ("", _, SFPROG _ _) -> waitSndDone sndr
+        r -> error $ "Expected SFDONE, got " <> show r
 
 testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
 testReceive rcp rfd = testReceiveCF rcp rfd Nothing

tests/XFTPServerTests.hs

@@ -22,6 +22,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import qualified Data.CaseInsensitive as CI
 import Data.List (find, isInfixOf)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Time.Clock (getCurrentTime)
 import qualified Data.X509 as X
 import Data.X509.Validation (Fingerprint (..), getFingerprint)
@@ -38,7 +39,6 @@ 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 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)

tests/XFTPWebTests.hs

@@ -49,8 +49,7 @@ import Simplex.FileTransfer.Server.Store (STMFileStore)
 import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpSendFile, xftpTestPort)
 import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent)
 import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers)
-import Simplex.Messaging.Agent.Protocol hiding (SFDONE)
-import qualified Simplex.Messaging.Agent.Protocol as A
+import Simplex.Messaging.Agent.Protocol (AEvent (..))
 import SMPAgentClient (agentCfg, initAgentServers, testDB)
 import XFTPCLI (recipientFiles, senderFiles, testBracket)
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -169,9 +168,6 @@ 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
@@ -2889,6 +2885,7 @@ webHandshakeTest cfg caFile = do
         \import sodium from 'libsodium-wrappers-sumo';\
         \import * as Addr from './dist/protocol/address.js';\
         \import * as Hs from './dist/protocol/handshake.js';\
+        \import * as Tx from './dist/protocol/transmission.js';\
         \import * as Id from './dist/crypto/identity.js';\
         \await sodium.ready;\
         \const server = Addr.parseXFTPServer('"
@@ -2909,7 +2906,7 @@ webHandshakeTest cfg caFile = do
              \ ? Id.verifyIdentityProof({certChainDer: hs.certChainDer, signedKeyDer: hs.signedKeyDer,\
              \sigBytes: hs.webIdentityProof, challenge, sessionId: hs.sessionId, keyHash: server.keyHash})\
              \ : false;\
-             \const ver = hs.xftpVersionRange.maxVersion;\
+             \const ver = Math.min(hs.xftpVersionRange.maxVersion, Tx.currentXFTPVersion);\
              \const s2 = client.request({':method': 'POST', ':path': '/', 'xftp-handshake': '1'});\
              \s2.end(Buffer.from(Hs.encodeClientHandshake({xftpVersion: ver, keyHash: server.keyHash})));\
              \const ack = await readBody(s2);\
@@ -3201,7 +3198,7 @@ haskellUploadTsDownloadTest cfg = do
       runRight_ $ xftpStartWorkers sndr (Just senderFiles)
       _ <- runRight $ xftpSendFile sndr 1 (CF.plain filePath) 1
       sfProgress sndr 50000
-      (_, _, SFDONE _ [rfd]) <- sfGet sndr
+      (_, _, SFDONE _ [rfd] _) <- sfGet sndr
       pure rfd
     let yamlDesc = strEncode vfd
         tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"