From 9507b2d6ea908cf4fd4779f2dbbc1d02ae75515b Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 18:41:56 +0000 Subject: [PATCH] refactor --- apps/xftp-server/XFTPWeb.hs | 2 +- plans/2026-08-22-xftp-file-storage-time.md | 32 ++++---- rfcs/2026-08-22-xftp-file-storage-time.md | 19 +++-- src/Simplex/FileTransfer/Agent.hs | 8 +- src/Simplex/FileTransfer/Client.hs | 14 +--- src/Simplex/FileTransfer/Client/Main.hs | 2 +- src/Simplex/FileTransfer/Protocol.hs | 36 ++++----- src/Simplex/FileTransfer/Server.hs | 75 ++++++++----------- src/Simplex/FileTransfer/Server/Env.hs | 17 ++--- src/Simplex/FileTransfer/Server/Main.hs | 13 ++-- src/Simplex/FileTransfer/Server/Store.hs | 12 ++- .../FileTransfer/Server/Store/Postgres.hs | 4 +- src/Simplex/FileTransfer/Types.hs | 19 +---- src/Simplex/Messaging/Agent.hs | 6 +- src/Simplex/Messaging/Agent/Client.hs | 23 +++--- .../Messaging/Agent/Store/AgentStore.hs | 6 +- .../M20260823_snd_files_entitlement.hs | 2 +- .../M20260823_snd_files_entitlement.hs | 2 +- tests/AgentTests/SQLiteTests.hs | 6 +- tests/XFTPAgent.hs | 2 +- tests/XFTPClient.hs | 2 +- tests/XFTPServerTests.hs | 11 ++- 22 files changed, 127 insertions(+), 186 deletions(-) diff --git a/apps/xftp-server/XFTPWeb.hs b/apps/xftp-server/XFTPWeb.hs index a9ee55e15..92978c166 100644 --- a/apps/xftp-server/XFTPWeb.hs +++ b/apps/xftp-server/XFTPWeb.hs @@ -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) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index 0973f0200..a2747f154 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -47,20 +47,14 @@ In `Simplex.FileTransfer.Transport`: In `Simplex.FileTransfer.Protocol`: -- add `FileStorageTime` and its encoding: - -``` -data FileStorageTime = FSMaxTime | FSTime {hours :: Word32} -``` - - add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants: ``` data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} ``` -- add the `FileStorageTime` and `Maybe EntitlementProof` fields to `FNEW` -- add the granted storage to `FRSndIds` +- 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`: @@ -71,30 +65,32 @@ In `Simplex.FileTransfer.Server`: In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: -- read a maximum storage time for each entitlement name from the INI file, as a number of hours +- 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` - exit at startup if any name's maximum is below the default file expiration - read the issuer public keys from the shared constant ## simplexmq: server store and expiration -The `files` table gets a nullable `expires_at`. `expires_at IS NULL` means "no explicit expiry — apply the configured default" (`created_at + ttl`); this covers legacy rows, which the migration must not re-date, since it has no access to the operator's configured TTL. +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`, resolve the requested time against the entitlement's maximum, store `expiresAt` from the resolution, and return the granted storage -- `expiredFiles` takes the configured default TTL and expires a file when `COALESCE(expiresAt, created_at + ttl) < now` -- retain `created_at` for statistics, export, and the default-expiry fallback +- 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 file when `maybe (created_at + ttl) roundedSeconds expiresAt < now` +- 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, now - ttl)`. 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. +- `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`: @@ -104,11 +100,11 @@ Store log, in `Simplex.FileTransfer.Server.StoreLog`: Public API in `Simplex.Messaging.Agent`: -- add `Maybe EntitlementCredential` and `FileStorageTime` parameters to `xftpSendFile` and `xftpSendDescription` +- 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 and a storage time column to `snd_files` +- 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 @@ -130,7 +126,7 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: ## Order 1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges. -2. Add `FileStorageTime`, the new XFTP version, the FNEW protocol change, and the response. +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. diff --git a/rfcs/2026-08-22-xftp-file-storage-time.md b/rfcs/2026-08-22-xftp-file-storage-time.md index c1c334965..ae9f4c4ac 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -26,13 +26,11 @@ The presentation header that the BBS proof is generated over is not transmitted; ## Storage time ``` -fileStorageTime = storageMax / storageFor -storageMax = %s"M" -storageFor = %s"F" storageHours -storageHours = 4*4 OCTET ; Word32, network byte order +fileStorageTime = %s"0" / (%s"1" storageHours) +storageHours = 8*8 OCTET ; Int64, network byte order ``` -`storageMax` requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. `storageFor` requests a specific number of hours. +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 @@ -50,13 +48,14 @@ optEntitlementProof = %s"0" / (%s"1" entitlementProof) FNEW extends the SIDS response with the granted storage. ``` -sndIds = %s"SIDS " senderId rcvIds grantedStorageTime +sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime +optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime) grantedStorageTime = grantedExpires -grantedExpires = %s"F" expiresAt +grantedExpires = %s"T" expiresAt expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order ``` -`grantedExpires` returns the absolute expiration. The sum encoding retains a one-character prefix so further variants can be added. `senderId` and `rcvIds` are defined by the current XFTP protocol. +`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 @@ -70,9 +69,9 @@ The chunk is identified by the sender key and the digest, which the server verif ## 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 treats an entitlement whose expiration has passed as no proof. +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. +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 diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 940abccd2..43e37b6ed 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -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 (..), FileStorageTime (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -351,7 +351,7 @@ 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 -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId +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" @@ -376,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}) Nothing FSMaxTime + 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 @@ -455,7 +455,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of [] -> Left ch SndFileChunkReplica {server} : _ -> Right server - createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk :: Int -> Maybe EntitlementCredential -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) createChunk numRecipients' credential storageTime ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index dd61420dd..fa120cea8 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -20,7 +20,6 @@ module Simplex.FileTransfer.Client xftpClientServer, xftpTransportHost, createXFTPChunk, - createXFTPChunkStorage, addXFTPRecipients, uploadXFTPChunk, downloadXFTPChunk, @@ -255,19 +254,10 @@ createXFTPChunk :: FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> - ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSMaxTime Nothing - -createXFTPChunkStorage :: - XFTPClient -> - C.APrivateAuthKey -> - FileInfo -> - NonEmpty C.APublicAuthKey -> - Maybe BasicAuth -> - FileStorageTime -> + Maybe Int64 -> Maybe EntitlementProof -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunkStorage c spKey file rcps auth_ storageTime proof = +createXFTPChunk c spKey file rcps auth_ storageTime proof = sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case (FRSndIds sId rIds _, body) -> noFile body (sId, rIds) (r, _) -> throwE $ unexpectedResponse r diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index fae8a6d0b..f8b172b6e 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -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 -> diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 36cc464bf..2005f2aa6 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -22,7 +22,6 @@ module Simplex.FileTransfer.Protocol FileCommand (..), FileCmd (..), FileInfo (..), - FileStorageTime (..), GrantedStorageTime (..), xftpNewProofHeader, XFTPFileId, @@ -181,7 +180,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where {-# INLINE protocolError #-} data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> 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 @@ -202,19 +201,6 @@ data FileInfo = FileInfo } deriving (Show) -data FileStorageTime = FSMaxTime | FSTime {hours :: Word32} - deriving (Eq, Show) - -instance Encoding FileStorageTime where - smpEncode = \case - FSMaxTime -> "M" - FSTime hours -> smpEncode ('F', hours) - smpP = - smpP >>= \case - 'M' -> pure FSMaxTime - 'F' -> FSTime <$> smpP - _ -> fail "bad FileStorageTime" - data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} deriving (Eq, Show) @@ -223,10 +209,10 @@ xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEnc instance Encoding GrantedStorageTime where smpEncode = \case - GSTExpires t -> smpEncode ('F', t) + GSTExpires t -> smpEncode ('T', t) smpP = smpP >>= \case - 'F' -> GSTExpires <$> smpP + 'T' -> GSTExpires <$> smpP _ -> fail "bad GrantedStorageTime" type XFTPFileId = EntityId @@ -235,8 +221,10 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand type Tag (FileCommand p) = FileCommandTag p encodeProtocol v = \case FNEW file rKeys auth_ st ep - | v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep) - | otherwise -> e (FNEW_, ' ', file, rKeys, auth_) + | 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_ @@ -274,8 +262,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where FCT SFSender tag -> FileCmd SFSender <$> case tag of FNEW_ - | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP - | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSMaxTime <*> pure Nothing + | 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 @@ -329,7 +319,7 @@ instance ProtocolMsgTag FileResponseTag where _ -> Nothing data FileResponse - = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorageTime + = FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime) | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey C.CbNonce | FROk @@ -357,7 +347,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where protocolP v = \case FRSndIds_ | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP - | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure (GSTExpires 0) + | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure Nothing FRRcvIds_ -> FRRcvIds <$> _smpP FRFile_ -> FRFile <$> _smpP <*> smpP FROk_ -> pure FROk diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 6cf6861d4..f40867160 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -35,7 +35,7 @@ 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 @@ -128,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 - when (isJust fileExpiration) $ expireServerFiles Nothing + expireServerFiles Nothing fileExpiration restoreServerStats raceAny_ ( runServer - : expireFilesThread_ cfg - <> serverStatsThread_ cfg + : expireFiles fileExpiration + : serverStatsThread_ cfg <> prometheusMetricsThread_ cfg <> controlPortThread_ cfg ) @@ -246,16 +246,12 @@ 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 forever $ do liftIO $ threadDelay' interval - expireServerFiles (Just 100000) + expireServerFiles (Just 100000) expCfg serverStatsThread_ :: XFTPServerConfig s -> [M s ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -486,36 +482,38 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse + 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 (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime + 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 expiresAt + 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 expiresAt 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 granted + pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt))) pure $ either FRErr id r - storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64) - storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config + 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 - defaultMax <- asks $ fmap ttl . fileExpiration . config + defaultMax <- asks $ ttl . fileExpiration . config now <- liftIO getCurrentTime let Entitlement {entitlementName, expiresAt} = ent liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case - Just True | expiresAt > now -> pure $ maybe defaultMax Just (M.lookup entitlementName entCfg) + 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 = @@ -658,33 +656,22 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime -resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorageTime) -resolveStorage base maxSeconds storageTime = (expiresAt, granted) - where - reqSeconds = case storageTime of - FSMaxTime -> maxSeconds - FSTime hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds - expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds - granted = GSTExpires $ base + fromMaybe 0 reqSeconds - -expireServerFiles :: FileStoreClass s => Maybe Int -> M s () -expireServerFiles itemDelay = - asks (fileExpiration . config) >>= \case - Nothing -> pure () - Just ExpirationConfig {ttl = defaultTtl} -> do - st <- asks fileStore - us <- asks usedStorage - usedStart <- readTVarIO us - now <- liftIO $ roundedSeconds <$> getSystemSeconds - filesCount <- liftIO $ getFileCount st - logNote $ "Expiration check: " <> tshow filesCount <> " files" - expireLoop st us now defaultTtl - usedEnd <- readTVarIO us - logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." +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 + old <- liftIO $ expireBeforeEpoch expCfg + filesCount <- liftIO $ getFileCount st + logNote $ "Expiration check: " <> tshow filesCount <> " files" + 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 now defaultTtl = do - expired <- liftIO $ expiredFiles st now defaultTtl 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 -> @@ -697,7 +684,7 @@ expireServerFiles itemDelay = unless (null sIds) $ do withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds liftIO $ deleteFiles st sIds - expireLoop st us now defaultTtl + expireLoop st us now old randomId :: Int -> M s ByteString randomId n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index a24ec48bb..c42e4050a 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -45,7 +45,7 @@ import Data.Word (Word32) import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T -import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId) +import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) @@ -92,7 +92,7 @@ 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, -- | timeout to receive file @@ -166,6 +166,9 @@ fromFileStore = \case #endif {-# INLINE fromFileStore #-} +defFileExpirationHours :: Int64 +defFileExpirationHours = 48 + defaultFileExpiration :: ExpirationConfig defaultFileExpiration = ExpirationConfig @@ -173,14 +176,10 @@ defaultFileExpiration = checkInterval = 2 * 3600 -- seconds, 2 hours } -storageAtLeast :: Int64 -> Maybe Int64 -> Bool -storageAtLeast _ Nothing = True -storageAtLeast a (Just b) = a >= b - newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do - let defaultMax = ttl <$> fileExpiration - unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ 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 @@ -207,7 +206,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExp pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Int64) (Maybe EntitlementProof) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index f9eb51242..b3c7b08a3 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -242,9 +242,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" @@ -290,10 +288,9 @@ 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, fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk inactiveClientExpiration = @@ -444,7 +441,7 @@ cliCommandP cfgPath logPath iniFile = iniEntitlements :: Ini -> Map T.Text Int64 iniEntitlements ini = - M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")] + M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")] where readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini)) parseMax t = (3600 *) <$> (readMaybe (T.unpack (T.strip t)) :: Maybe Int64) diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 0291ab114..1bbfaf07f 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -16,7 +16,6 @@ module Simplex.FileTransfer.Server.Store STMFileStore (..), RoundedFileTime, fileTimePrecision, - defFileExpirationHours, ) where @@ -65,9 +64,6 @@ type RoundedFileTime = RoundedSystemTime 3600 fileTimePrecision :: Int64 fileTimePrecision = 3600 -defFileExpirationHours :: Int64 -defFileExpirationHours = 48 - data FileRecipient = FileRecipient RecipientId C.APublicAuthKey deriving (Show) @@ -171,11 +167,13 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - expiredFiles STMFileStore {files} now defaultTtl _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, expiresAt}) -> - let effExpiry = maybe (createdAt + defaultTtl) roundedSeconds expiresAt - in if effExpiry < now + 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) diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 75a0b20dc..887ea23ed 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -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 now defaultTtl 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 (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?" - (now, now - defaultTtl, limit) + (now, 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 6593e36c8..4816d0d0e 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -39,10 +39,8 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word32) -import Text.Read (readMaybe) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileStorageTime (..)) import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C @@ -174,7 +172,7 @@ data SndFile = SndFile deleted :: Bool, redirect :: Maybe RedirectFileInfo, entitlementCredential :: Maybe EntitlementCredential, - storageTime :: FileStorageTime + storageTime :: Maybe Int64 } deriving (Show) @@ -194,21 +192,6 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode instance ToField SndFileStatus where toField = toField . textEncode -fileStorageTimeText :: FileStorageTime -> Text -fileStorageTimeText = \case - FSMaxTime -> "max" - FSTime h -> "for " <> T.pack (show h) - -fileStorageTimeParse :: Text -> Maybe FileStorageTime -fileStorageTimeParse s = case T.words s of - ["max"] -> Just FSMaxTime - ["for", h] -> FSTime <$> readMaybe (T.unpack h) - _ -> Nothing - -instance ToField FileStorageTime where toField = toField . fileStorageTimeText - -instance FromField FileStorageTime where fromField = fromTextField_ fileStorageTimeParse - instance ToField EntitlementCredential where toField = toField . decodeUtf8 . LB.toStrict . JD.encode instance FromField EntitlementCredential where fromField = fromTextField_ (JD.decode . LB.fromStrict . encodeUtf8) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f79ae3741..4423014bd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -191,7 +191,7 @@ import Data.Traversable (mapAccumL) import Data.Word (Word16) import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile') import Simplex.FileTransfer.Description (ValidFileDescription) -import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..)) +import Simplex.FileTransfer.Protocol (FileParty (..)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client @@ -776,10 +776,10 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c -- | Send XFTP file xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId -xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSMaxTime +xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing Nothing {-# INLINE xftpSendFile #-} -xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId +xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime {-# INLINE xftpSendFileStorage #-} diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index fb7b0dc72..97e04d056 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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, FileStorageTime, xftpNewProofHeader) +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,7 +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 (..), EntitlementProof, entitlementIssuerKeys, generateEntitlementProof) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), entitlementIssuerKeys, generateEntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client @@ -1346,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 @@ -2187,7 +2187,7 @@ 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 -> Maybe EntitlementCredential -> FileStorageTime -> AM NewSndChunkReplica +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 @@ -2195,18 +2195,15 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> do - proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey chunkDigest credential - X.createXFTPChunkStorage xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof + proof <- liftIO $ case credential of + Nothing -> pure Nothing + Just cred@EntitlementCredential {issuerKeyIdx} -> case M.lookup issuerKeyIdx entitlementIssuerKeys of + Nothing -> pure Nothing + Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader (sessionId $ X.thParams xftp) sndKey chunkDigest) + 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} -mkEntitlementProof :: SessionId -> C.APublicAuthKey -> ByteString -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof) -mkEntitlementProof _ _ _ Nothing = pure Nothing -mkEntitlementProof sessId sndKey digest (Just cred@EntitlementCredential {issuerKeyIdx}) = - case M.lookup issuerKeyIdx entitlementIssuerKeys of - Nothing -> pure Nothing - Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey digest) - agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 19baa394b..09c574573 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -309,7 +309,7 @@ import Network.Socket (ServiceName) import qualified Network.TLS as TLS import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) import Simplex.FileTransfer.Types import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Protocol @@ -3425,7 +3425,7 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId) +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 @@ -3477,7 +3477,7 @@ 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 EntitlementCredential, FileStorageTime) -> SndFile + 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 diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs index 50b517c1a..ea630f28d 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs @@ -10,7 +10,7 @@ m20260823_snd_files_entitlement :: Text m20260823_snd_files_entitlement = [r| ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; -ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; +ALTER TABLE snd_files ADD COLUMN storage_time BIGINT; |] down_m20260823_snd_files_entitlement :: Text diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs index 859786ebb..e0bc3cde9 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs @@ -9,7 +9,7 @@ m20260823_snd_files_entitlement :: Query m20260823_snd_files_entitlement = [sql| ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; -ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; +ALTER TABLE snd_files ADD COLUMN storage_time INTEGER; |] down_m20260823_snd_files_entitlement :: Query diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 9f95f503d..3836332f2 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -782,7 +782,7 @@ testGetNextSndFileToPrepare st = do -- Can't test it with strict tables -- Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing -- DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1" - Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSMaxTime + 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 @@ -808,13 +808,13 @@ testGetNextSndChunkToUpload st = do Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400 -- create file 1 - Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSMaxTime + 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 Nothing FSMaxTime + 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 diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 34da3d125..3d22d41d3 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -619,7 +619,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 diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index d8280ef6e..5e8651d30 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -181,7 +181,7 @@ testXFTPServerConfig = newFileBasicAuth = Nothing, controlPortAdminAuth = Nothing, controlPortUserAuth = Nothing, - fileExpiration = Just defaultFileExpiration, + fileExpiration = defaultFileExpiration, fileStorageEntitlements = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index d3d53e6b8..4b2aed6a9 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -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 = 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