diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index 65627ef5e..264c0b273 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -55,7 +55,7 @@ In `Simplex.FileTransfer.Protocol`: data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} ``` -- add the storage time (`Maybe Word32`: `Nothing` requests the server maximum, `Just` a number of hours) to `FNEW` +- add the storage time (`Maybe Word32`: `Nothing` and `Just 0` request the server maximum, a value above zero requests that number of hours) to `FNEW` - add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version) ## simplexmq: server configuration @@ -71,7 +71,7 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: In `Simplex.FileTransfer.Server`: -- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. It takes the resolution as a parameter: the first handshake verifies, a repeated handshake with the `xftp-handshake` header keeps the entitlement of the session and verifies nothing +- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. `HandshakeSent` carries `EntitlementChecked`, so the first handshake verifies and every later one on that connection reuses the result, including after `processHello` returns the session to `HandshakeSent` - verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum - a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed - `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise @@ -114,7 +114,7 @@ Per-user state in `Simplex.Messaging.Agent.Env.SQLite` and `Simplex.Messaging.Ag Public API in `Simplex.Messaging.Agent`: - add storage time (`Maybe Word32` hours) to `xftpSendFile` -- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and closes that user's XFTP clients, so the next upload presents the new credential +- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and when the credential changed it closes that user's XFTP clients, so the next upload presents the new credential Store, in both the SQLite and PostgreSQL agent stores: diff --git a/rfcs/2026-08-22-xftp-file-storage-time.md b/rfcs/2026-08-22-xftp-file-storage-time.md index fdcb476d7..de00a441f 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -38,7 +38,7 @@ fileStorageTime = %s"0" / (%s"1" storageHours) storageHours = 4*4 OCTET ; Word32, network byte order ``` -The storage time is an optional number of hours. Absent (`%s"0"`) requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value (`%s"1"` with hours) requests a specific number of hours. +The storage time is an optional number of hours. Absent (`%s"0"`), or present as zero hours, requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value above zero requests that number of hours, and the server grants the smaller of it and the maximum. ## Handshake, new XFTP version @@ -51,7 +51,7 @@ optEntitlementProof = %s"0" / (%s"1" entitlementProof) `xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof. -The server verifies the proof when it accepts the handshake and keeps the result for the session; a repeated handshake carrying the `xftp-handshake` header keeps that result and verifies nothing. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures. +The server verifies the proof when it accepts the handshake and keeps the result for the session; further handshakes on the same connection keep that result and verify nothing, so a session costs one verification however many handshakes it makes. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures. ## Commands diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 3752c59e2..005dd6dbe 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -352,7 +352,7 @@ notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEv notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId -xftpSendFile' c userId file numRecipients storageTime = do +xftpSendFile' c userId file numRecipients storageHours = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath @@ -360,7 +360,7 @@ xftpSendFile' c userId file numRecipients storageTime = do key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageTime + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -406,7 +406,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do prepareFile _ SndFile {prefixPath = Nothing} = throwE $ INTERNAL "no prefix path" prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do - SndFile {numRecipients, chunks, storageTime} <- + SndFile {numRecipients, chunks, storageHours} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath @@ -425,7 +425,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - srvs <- forM pendingChunks $ createChunk numRecipients' storageTime + srvs <- forM pendingChunks $ createChunk numRecipients' storageHours let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -456,7 +456,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do [] -> Left ch SndFileChunkReplica {server} : _ -> Right server createChunk :: Int -> Maybe Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) - createChunk numRecipients' storageTime ch = do + createChunk numRecipients' storageHours ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica @@ -483,7 +483,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId when deleted $ throwE $ FILE NO_FILE withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do - replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageTime + replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageHours pure (replica, srvAuth) sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index f84080cc0..270f210f7 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -258,8 +258,8 @@ createXFTPChunk :: Maybe BasicAuth -> Maybe Word32 -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) -createXFTPChunk c spKey file rcps auth_ storageTime = - sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime) Nothing >>= \case +createXFTPChunk c spKey file rcps auth_ storageHours = + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageHours) Nothing >>= \case (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs) (r, _) -> throwE $ unexpectedResponse r diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 99b77563f..0f6ac5cfa 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -124,9 +124,12 @@ runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s -> runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) data Handshake - = HandshakeSent C.PrivateKeyX25519 + = HandshakeSent C.PrivateKeyX25519 EntitlementChecked | HandshakeAccepted (THandleParams XFTPVersion 'TServer) +-- | the entitlement of the session is resolved once, however many handshakes it has +data EntitlementChecked = EntNotChecked | EntChecked (Maybe SessionEntitlement) + xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do expireServerFiles Nothing fileExpiration @@ -178,12 +181,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira Nothing | sniUsed && not webHello -> throwE SESSION | otherwise -> processHello Nothing - Just (HandshakeSent pk) + Just (HandshakeSent pk ent_) | webHello -> processHello (Just pk) - | otherwise -> processClientHandshake pk verifiedEntitlement + | otherwise -> processClientHandshake pk ent_ Just (HandshakeAccepted thParams) | webHello -> processHello (serverPrivKey <$> thAuth thParams) - | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (const . pure $ peerEntitlement auth) + | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (EntChecked $ peerEntitlement auth) | otherwise -> pure $ Just thParams either sendError pure r where @@ -200,10 +203,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira | otherwise -> throwE HANDSHAKE rng <- asks random k <- atomically $ TM.lookup sessionId sessions >>= \case - Just (HandshakeSent pk') -> pure $ C.publicKey pk' - _ -> do + Just (HandshakeSent pk' _) -> pure $ C.publicKey pk' + s' -> do kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_ - fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions + let ent_ = case s' of + Just (HandshakeAccepted thParams) -> EntChecked $ peerEntitlement =<< thAuth thParams + _ -> EntNotChecked + fst kp <$ TM.insert sessionId (HandshakeSent (snd kp) ent_) sessions let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k) webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_ let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof} @@ -213,7 +219,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira #endif liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs pure Nothing - processClientHandshake pk sessionEntitlement = do + processClientHandshake pk ent_ = do unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE body <- liftHS $ C.unPad bodyHead XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body @@ -221,7 +227,9 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira unless (keyHash == kh) $ throwE HANDSHAKE case compatibleVRange' xftpServerVRange v of Just (Compatible vr) -> do - ent <- lift $ sessionEntitlement entitlementProof + ent <- case ent_ of + EntChecked ent -> pure ent + EntNotChecked -> lift $ verifiedEntitlement entitlementProof let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing} thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions @@ -481,7 +489,7 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = processXFTPRequest :: forall s. FileStoreClass s => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) processXFTPRequest ent HTTP2Body {bodyPart} = \case - XFTPReqNew file rks auth storageTime -> noFile =<< ifM allowNew (createFile file rks storageTime) (pure $ FRErr AUTH) + XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -499,16 +507,19 @@ processXFTPRequest ent HTTP2Body {bodyPart} = \case where noFile resp = pure (resp, Nothing) createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse - createFile file rks storageTime = do + createFile file rks storageHours = do st <- asks fileStore r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE - ts <- liftIO getFileTime now <- liftIO getSystemSeconds maxSeconds <- lift $ storageMaxSeconds now - let secs = maybe maxSeconds (\hours -> min maxSeconds (fromIntegral hours * 3600)) storageTime - fileExpiresAt = RoundedSystemTime $ ((roundedSeconds now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision + let nowSeconds = roundedSeconds now + ts = RoundedSystemTime $ (nowSeconds `div` fileTimePrecision) * fileTimePrecision + secs = case storageHours of + Just hours | hours > 0 -> min maxSeconds (fromIntegral hours * 3600) + _ -> maxSeconds + fileExpiresAt = RoundedSystemTime $ ((nowSeconds + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision -- TODO validate body empty sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt) rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks @@ -668,15 +679,12 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce entitlementValid :: SystemSeconds -> SystemSeconds -> Bool entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now -getFileTime :: IO RoundedFileTime -getFileTime = getRoundedSystemTime - expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s () expireServerFiles itemDelay expCfg = do st <- asks fileStore us <- asks usedStorage usedStart <- readTVarIO us - now <- liftIO $ roundedSeconds <$> getSystemSeconds + now <- liftIO getSystemSeconds old <- liftIO $ expireBeforeEpoch expCfg filesCount <- liftIO $ getFileCount st logNote $ "Expiration check: " <> tshow filesCount <> " files" diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 387ff5bb9..30ec1027f 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -160,10 +160,12 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do \# db_pool_size = 10\n\n\ \# Write database changes to store log file\n\ \# db_store_log = off\n\n" - <> "# Expire files after the specified number of hours.\n" + <> "# Expire files after the specified number of hours.\n\ + \# The change only affects new files.\n" <> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n") <> "# Expire files after the specified number of hours for the senders that present\n\ \# a proof of the entitlement. Must not be below expire_files_hours.\n\ + \# The change only affects new files.\n\ \# expire_files_hours_for_supporter = 168\n\ \# expire_files_hours_for_legend = 504\n\n" <> "log_stats = off\n\ diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 1bbfaf07f..371a5eea4 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -85,7 +85,7 @@ class FileStoreClass s where deleteRecipient :: s -> RecipientId -> FileRec -> IO () getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey)) ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ()) - expiredFiles :: s -> Int64 -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] + expiredFiles :: s -> SystemSeconds -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] getUsedStorage :: s -> IO Int64 getFileCount :: s -> IO Int @@ -171,7 +171,7 @@ instance FileStoreClass STMFileStore where fs <- readTVarIO files fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) -> let expired = case expiresAt of - Just e -> roundedSeconds e < now + Just e -> roundedSeconds e < roundedSeconds now Nothing -> createdAt + fileTimePrecision < old in if expired then do diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 3b389b7fc..c9e83c4c5 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -55,6 +55,7 @@ import Simplex.Messaging.Transport (EntityId (..)) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.QueueStore.Postgres () import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) +import Simplex.Messaging.SystemTime (roundedSeconds) import Simplex.Messaging.Util (firstRow, tshow) import System.Directory (renameFile) import System.Exit (exitFailure) @@ -157,7 +158,7 @@ instance FileStoreClass PostgresFileStore where DB.query db "(SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)" - (now, limit, old - fileTimePrecision, limit) + (roundedSeconds now, limit, old - fileTimePrecision, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ad522109a..e9e4c1a85 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -169,7 +169,7 @@ data SndFile = SndFile status :: SndFileStatus, deleted :: Bool, redirect :: Maybe RedirectFileInfo, - storageTime :: Maybe Word32 + storageHours :: Maybe Word32 } deriving (Show) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 744b456a8..b7aa37ddd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -3055,8 +3055,12 @@ setProtocolServers c userId srvs = do -- The credential is presented in the handshake, so the user's XFTP clients are closed to present the new one. setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO () setUserEntitlement c userId cred_ = do - atomically $ maybe (TM.delete userId) (TM.insert userId) cred_ $ userEntitlements c - closeUserXFTPClients c userId + changed <- atomically $ do + prev_ <- TM.lookup userId $ userEntitlements c + if prev_ == cred_ + then pure False + else True <$ maybe (TM.delete userId) (TM.insert userId) cred_ (userEntitlements c) + when changed $ closeUserXFTPClients c userId checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () checkUserServers name srvs = diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 652eeee18..56a9dc5ea 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -227,14 +227,14 @@ import qualified Data.Set as S import Data.Text (Text) import Data.Text.Encoding import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) -import Data.Time.Clock.System (getSystemTime) +import Data.Time.Clock.System (getSystemTime, systemSeconds) import Data.Word (Word16, Word32) import qualified Data.X509.Validation as XV import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb) -import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) +import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, GrantedStorageTime (..)) import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..)) @@ -901,10 +901,18 @@ getXFTPServerClient c@AgentClient {active, xftpClients, userEntitlements, worker mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof) mkEntitlementProof keys sessId = - TM.lookupIO userId userEntitlements $>>= \cred -> - generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case - Right p -> pure $ Just p - Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) + ifM knownServer proof (pure Nothing) + where + -- the entitlement is presented only to the servers of this user, matched by key hash that TLS pins, + -- so a file description of the sender cannot direct it to another server + knownServer = maybe False (any (sameKeyHash . snd) . storageSrvs) <$> TM.lookupIO userId (xftpServers c) + sameKeyHash (ProtoServerWithAuth srv' _) = srvKeyHash srv' == srvKeyHash srv + srvKeyHash (ProtocolServer _ _ _ kh) = kh + proof = + TM.lookupIO userId userEntitlements $>>= \cred -> + generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case + Right p -> pure $ Just p + Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do @@ -2208,15 +2216,20 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageTime = do +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageHours = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> - X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime + X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageHours logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] + liftIO $ forM_ ((,) <$> storageHours <*> expiresAt) $ \(hours, GSTExpires t) -> do + now <- systemSeconds <$> getSystemTime + let granted = (t - now + 3599) `div` 3600 + when (granted < fromIntegral hours) $ + logWarn $ "requested " <> tshow hours <> " hours of storage, granted " <> tshow granted pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt} agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index cd212b4a8..e9946cca0 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -3425,12 +3425,12 @@ getRcvFilesExpired db ttl = do (Only cutoffTs) createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Word32 -> IO (Either StoreError SndFileId) -createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageTime = +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageHours = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageTime)) + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageHours)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3477,11 +3477,11 @@ getSndFile db sndFileId = runExceptT $ do (Only sndFileId) where toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe Word32) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageTime)) = + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageHours)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageTime, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageHours, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 75fde9911..13d831fe1 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -209,6 +209,25 @@ deriving instance Eq FileStoreLogRecord testFileStoreLogFile :: FilePath testFileStoreLogFile = "tests/tmp/xftp-server-store.log" +fileExpirationTests :: Spec +fileExpirationTests = + describe "XFTP file expiration" $ + it "expires by stored expiration and by creation time" testExpiredFiles + +testExpiredFiles :: Expectation +testExpiredFiles = do + st <- newFileStore () :: IO STMFileStore + g <- C.newRandom + (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + let file = FileInfo {sndKey, size = 16384, digest = "12345678"} + created = RoundedSystemTime 100000 + addFile st (EntityId "expired_stored__") file created (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right () + addFile st (EntityId "stored_ahead____") file created (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right () + addFile st (EntityId "legacy_expired__") file created Nothing EntityActive `shouldReturn` Right () + addFile st (EntityId "legacy_in_grace_") file (RoundedSystemTime 297000) Nothing EntityActive `shouldReturn` Right () + expired <- expiredFiles st (RoundedSystemTime 500000) 300000 100 + map (\(sId, _, _) -> sId) expired `shouldMatchList` [EntityId "expired_stored__", EntityId "legacy_expired__"] + fileStoreLogTests :: Spec fileStoreLogTests = do g <- runIO C.newRandom diff --git a/tests/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index e2f59b484..9f980b4ea 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -197,7 +197,7 @@ testExpiredFiles = withPgStore $ \st -> do void $ setFilePath st (EntityId "old_file________") "/tmp/old" addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right () -- Query expired with cutoff that only catches old file - expired <- expiredFiles st 500000 500000 100 + expired <- expiredFiles st (RoundedSystemTime 500000) 500000 100 length expired `shouldBe` 1 case expired of [(sId, path, sz)] -> do @@ -215,7 +215,7 @@ testExpiredFilesStoredExpiration = withPgStore $ \st -> do -- both files are created before the cutoff, the stored expiration decides addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right () addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right () - expired <- expiredFiles st 500000 0 100 + expired <- expiredFiles st (RoundedSystemTime 500000) 0 100 map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"] testStorageAndCount :: Expectation diff --git a/tests/Test.hs b/tests/Test.hs index 77229a28f..5c135df4f 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -98,6 +98,7 @@ main = do describe "Store log tests" storeLogTests #endif describe "XFTP store log tests" fileStoreLogTests + fileExpirationTests describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests describe "Names resolver tests" smpNamesTests