From ed9786af1ca5e7710db2ca553359015800cc1727 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 12:19:23 +0000 Subject: [PATCH] remove permanent and FTTL --- plans/2026-08-22-xftp-file-storage-time.md | 49 +++++++++---------- rfcs/2026-08-22-xftp-file-storage-time.md | 25 ++++------ src/Simplex/FileTransfer/Agent.hs | 14 +----- src/Simplex/FileTransfer/Client.hs | 9 +--- src/Simplex/FileTransfer/Protocol.hs | 46 ++++++----------- src/Simplex/FileTransfer/Server.hs | 39 +++++---------- src/Simplex/FileTransfer/Server/Env.hs | 11 ++--- src/Simplex/FileTransfer/Server/Main.hs | 6 +-- src/Simplex/FileTransfer/Server/Store.hs | 23 +++------ .../FileTransfer/Server/Store/Postgres.hs | 42 +++++++--------- .../Server/Store/Postgres/Migrations.hs | 4 +- src/Simplex/FileTransfer/Server/StoreLog.hs | 36 +++++--------- src/Simplex/FileTransfer/Types.hs | 8 +-- src/Simplex/Messaging/Agent.hs | 12 ++--- src/Simplex/Messaging/Agent/Client.hs | 16 +----- tests/AgentTests/SQLiteTests.hs | 6 +-- 16 files changed, 120 insertions(+), 226 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index ae0d5fd08..0973f0200 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -50,12 +50,18 @@ In `Simplex.FileTransfer.Protocol`: - add `FileStorageTime` and its encoding: ``` -data FileStorageTime = FSTMax | FSTFor Word32 -- FSTMax may resolve to permanent; FSTFor: hours +data FileStorageTime = FSMaxTime | FSTime {hours :: Word32} ``` -- add the `FileStorageTime` and `Maybe EntitlementProof` fields to `FNEW`, and add `FTTL` -- add the expiration to `FRSndIds`, and add a new response for `FTTL` -- build the presentation header for FNEW and for FTTL +- 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` +- build the presentation header for FNEW In `Simplex.FileTransfer.Server`: @@ -65,43 +71,40 @@ In `Simplex.FileTransfer.Server`: In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: -- read a maximum storage time for each entitlement name, and a default maximum, from the INI file, where each maximum is a number of hours or permanent -- exit at startup if any name's maximum is below the default +- read a maximum storage time for each entitlement name from the INI file, as a number of hours +- 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` and a `permanent BOOLEAN NOT NULL DEFAULT false`. `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. `permanent = true` means the file never expires and keeps `expires_at` NULL, so a legacy row and a permanent row are distinguished by the flag, not by overloading NULL. The flag is also directly queryable for analytics. +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. Common to both stores, in `Simplex.FileTransfer.Server.Store`: -- add `expiresAt :: Maybe RoundedFileTime` and `permanent :: Bool` to `FileRec` -- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the entitlement's maximum, and store `expiresAt`/`permanent` from the resolution (permanent when the ceiling is unbounded); return the granted storage -- add the FTTL handler, which verifies the proof against `sessionId <> sndKey <> digest`, sets `expiresAt`/`permanent` by the same resolution, and returns it -- `expiredFiles` takes the configured default TTL and expires a non-permanent file when `COALESCE(expiresAt, created_at + ttl) < now` +- 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 STM store: -- in `expiredFiles`, expire a file when `not permanent && maybe (created_at + ttl) roundedSeconds expiresAt < now` +- in `expiredFiles`, expire a file when `maybe (created_at + ttl) roundedSeconds expiresAt < now` PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations: -- add the nullable column `expires_at BIGINT` and `permanent BOOLEAN NOT NULL DEFAULT FALSE` (no backfill) -- add one composite index `idx_files_expiry ON files (permanent, expires_at, created_at)` -- `expiredFiles` query: `WHERE (NOT permanent AND expires_at < ?) OR (NOT permanent AND 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 one composite index): `permanent` leads (equality seek skips permanent rows), `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. +- 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. Store log, in `Simplex.FileTransfer.Server.StoreLog`: -- add the `permanent` flag and the optional expiration to the `AddFile` record; a record with neither parses to `False`/`Nothing` (the configured default), never a hardcoded value -- for older records without an expiration, default `expiresAt` to `createdAt + default storage time` +- add the optional expiration to the `AddFile` record; a record without it parses to `Nothing` (the configured default), never a hardcoded value ## simplexmq: agent Public API in `Simplex.Messaging.Agent`: - add `Maybe EntitlementCredential` and `FileStorageTime` parameters to `xftpSendFile` and `xftpSendDescription` -- add a set-time API for FTTL that operates per chunk, using the sender description Store, in both the SQLite and PostgreSQL agent stores: @@ -115,15 +118,11 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: - inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof - discard the returned expiration for now -Set-time: - -- for a completed file, generate a per-chunk proof bound to `sessionId <> sndKey <> digest` and send FTTL, authorized with the sender key - ## simplex-chat - remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI - map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent -- pass the user's credential and `FSTMax` to `xftpSendFile` +- pass the user's credential and `FSMaxTime` to `xftpSendFile` - retain the `maxXFTPFileSize` size limit - reuse `verifyEntitlement` for peer-badge verification - import the issuer public keys from the shared simplexmq constant @@ -131,7 +130,7 @@ Set-time: ## 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 and FTTL protocol changes, and the responses. +2. Add `FileStorageTime`, the new XFTP version, the FNEW protocol change, and the response. 3. Change the server configuration, store, expiration, and store log. -4. Change the agent store, add proof generation on upload, and add the set-time API. +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 5f6884770..c1c334965 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -2,7 +2,7 @@ ## Summary -The server stores a storage time for each file. The sender sets it in the FNEW command and resets it with a new FTTL command. The sender may present a proof of an entitlement to raise the maximum storage time the server allows. Each proof is bound to the uploaded chunk and to the TLS session, so it cannot be reused for another chunk or another session. +The server stores a storage time for each file. The sender sets it in the FNEW command. The sender may present a proof of an entitlement to raise the maximum storage time the server allows. Each proof is bound to the uploaded chunk and to the TLS session, so it cannot be reused for another chunk or another session. ## Entitlement @@ -32,40 +32,35 @@ storageFor = %s"F" storageHours storageHours = 4*4 OCTET ; Word32, network byte order ``` -`storageMax` requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present; this maximum may be permanent. `storageFor` requests a specific number of hours. +`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. ## Commands, new XFTP version -The new protocol version extends FNEW and adds FTTL. +The new protocol version extends FNEW. ``` fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime optEntitlementProof -fttl = %s"FTTL " fileStorageTime optEntitlementProof optEntitlementProof = %s"0" / (%s"1" entitlementProof) ``` -FTTL is authorized with the sender key of the file, as the other sender commands are. It sets the expiration to the resolved storage time (see [Maximum storage time](#maximum-storage-time)) and may reduce the current expiration, since the sender can also delete the file. - `fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode neither `fileStorageTime` nor the proof, and the server applies the default storage time. ## Responses -FNEW extends the SIDS response with the granted storage, and FTTL adds a response. +FNEW extends the SIDS response with the granted storage. ``` -sndIds = %s"SIDS " senderId rcvIds grantedStorage -fileTime = %s"TTL " grantedStorage -grantedStorage = grantedExpires / grantedPerm +sndIds = %s"SIDS " senderId rcvIds grantedStorageTime +grantedStorageTime = grantedExpires grantedExpires = %s"F" expiresAt -grantedPerm = %s"P" expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order ``` -`grantedExpires` returns the absolute expiration, and `grantedPerm` indicates permanent storage. `senderId` and `rcvIds` are defined by the current XFTP protocol. +`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. ## Binding -The presentation header binds each proof to the TLS session and to the specific chunk. The server reconstructs it and rejects a proof generated for any other session or chunk. FNEW and FTTL use the same header. +The presentation header binds each proof to the TLS session and to the specific chunk. The server reconstructs it and rejects a proof generated for any other session or chunk. ``` presHeader = sessionId sndKey digest @@ -75,9 +70,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 or permanent. 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 treats an entitlement whose expiration has passed as no proof. -If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. `storageMax` yields permanent storage when the entitlement's maximum is permanent, and the finite maximum otherwise. +If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. ## Encoding primitives diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index b3a157da3..940abccd2 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -22,7 +22,6 @@ module Simplex.FileTransfer.Agent -- Sending files xftpSendFile', xftpSendDescription', - xftpSetFileTime', deleteSndFileInternal, deleteSndFilesInternal, deleteSndFileRemote, @@ -55,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 (..), GrantedStorage, SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -377,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 FSTMax + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing FSMaxTime lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -641,15 +640,6 @@ deleteSndFilesInternal c sndFileEntityIds = do batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> AM' () batchFiles_ f sndFiles = void $ withStoreBatch' c $ \db -> map (\SndFile {sndFileId} -> f db sndFileId) sndFiles -xftpSetFileTime' :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AM [GrantedStorage] -xftpSetFileTime' c userId (ValidFileDescription FileDescription {chunks}) storageTime credential = - forM (mapMaybe chunkReplica chunks) $ \(server, replicaId, replicaKey, digest) -> - agentXFTPSetChunkTime c userId server replicaId replicaKey digest storageTime credential - where - chunkReplica = \case - FileChunk {digest, replicas = FileChunkReplica {server, replicaId, replicaKey} : _} -> Just (server, replicaId, replicaKey, digest) - _ -> Nothing - deleteSndFileRemote :: AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> AM' () deleteSndFileRemote c userId sndFileEntityId sfd = deleteSndFilesRemote c userId [(sndFileEntityId, sfd)] diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 151725d4d..dd61420dd 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -21,7 +21,6 @@ module Simplex.FileTransfer.Client xftpTransportHost, createXFTPChunk, createXFTPChunkStorage, - setXFTPChunkTime, addXFTPRecipients, uploadXFTPChunk, downloadXFTPChunk, @@ -257,7 +256,7 @@ createXFTPChunk :: NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSTMax Nothing +createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSMaxTime Nothing createXFTPChunkStorage :: XFTPClient -> @@ -273,12 +272,6 @@ createXFTPChunkStorage c spKey file rcps auth_ storageTime proof = (FRSndIds sId rIds _, body) -> noFile body (sId, rIds) (r, _) -> throwE $ unexpectedResponse r -setXFTPChunkTime :: XFTPClient -> C.APrivateAuthKey -> SenderId -> FileStorageTime -> Maybe EntitlementProof -> ExceptT XFTPClientError IO GrantedStorage -setXFTPChunkTime c spKey sId storageTime proof = - sendXFTPCommand c spKey sId (FTTL storageTime proof) Nothing >>= \case - (FRFileTime gs, body) -> noFile body gs - (r, _) -> throwE $ unexpectedResponse r - addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) addXFTPRecipients c spKey fId rcps = sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 75abd14aa..36cc464bf 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -23,9 +23,8 @@ module Simplex.FileTransfer.Protocol FileCmd (..), FileInfo (..), FileStorageTime (..), - GrantedStorage (..), + GrantedStorageTime (..), xftpNewProofHeader, - xftpTimeProofHeader, XFTPFileId, FileResponse (..), xftpBlockSize, @@ -130,7 +129,6 @@ data FileCommandTag (p :: FileParty) where FADD_ :: FileCommandTag FSender FPUT_ :: FileCommandTag FSender FDEL_ :: FileCommandTag FSender - FTTL_ :: FileCommandTag FSender FGET_ :: FileCommandTag FRecipient FACK_ :: FileCommandTag FRecipient PING_ :: FileCommandTag FRecipient @@ -145,7 +143,6 @@ instance FilePartyI p => Encoding (FileCommandTag p) where FADD_ -> "FADD" FPUT_ -> "FPUT" FDEL_ -> "FDEL" - FTTL_ -> "FTTL" FGET_ -> "FGET" FACK_ -> "FACK" PING_ -> "PING" @@ -161,7 +158,6 @@ instance ProtocolMsgTag FileCmdTag where "FADD" -> Just $ FCT SFSender FADD_ "FPUT" -> Just $ FCT SFSender FPUT_ "FDEL" -> Just $ FCT SFSender FDEL_ - "FTTL" -> Just $ FCT SFSender FTTL_ "FGET" -> Just $ FCT SFRecipient FGET_ "FACK" -> Just $ FCT SFRecipient FACK_ "PING" -> Just $ FCT SFRecipient PING_ @@ -189,7 +185,6 @@ data FileCommand (p :: FileParty) where FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender - FTTL :: FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender FGET :: RcvPublicDhKey -> FileCommand FRecipient FACK :: FileCommand FRecipient PING :: FileCommand FRecipient @@ -207,37 +202,32 @@ data FileInfo = FileInfo } deriving (Show) -data FileStorageTime = FSTMax | FSTFor Word32 +data FileStorageTime = FSMaxTime | FSTime {hours :: Word32} deriving (Eq, Show) instance Encoding FileStorageTime where smpEncode = \case - FSTMax -> "M" - FSTFor hours -> smpEncode ('F', hours) + FSMaxTime -> "M" + FSTime hours -> smpEncode ('F', hours) smpP = smpP >>= \case - 'M' -> pure FSTMax - 'F' -> FSTFor <$> smpP + 'M' -> pure FSMaxTime + 'F' -> FSTime <$> smpP _ -> fail "bad FileStorageTime" -data GrantedStorage = GrantedExpires Int64 | GrantedPermanent +data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} deriving (Eq, Show) xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest -xftpTimeProofHeader :: SessionId -> SenderId -> BBSPresHeader -xftpTimeProofHeader sessionId sId = BBSPresHeader $ sessionId <> unEntityId sId - -instance Encoding GrantedStorage where +instance Encoding GrantedStorageTime where smpEncode = \case - GrantedExpires t -> smpEncode ('F', t) - GrantedPermanent -> "P" + GSTExpires t -> smpEncode ('F', t) smpP = smpP >>= \case - 'F' -> GrantedExpires <$> smpP - 'P' -> pure GrantedPermanent - _ -> fail "bad GrantedStorage" + 'F' -> GSTExpires <$> smpP + _ -> fail "bad GrantedStorageTime" type XFTPFileId = EntityId @@ -250,7 +240,6 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand FADD rKeys -> e (FADD_, ' ', rKeys) FPUT -> e FPUT_ FDEL -> e FDEL_ - FTTL st ep -> e (FTTL_, ' ', st, ep) FGET rKey -> e (FGET_, ' ', rKey) FACK -> e FACK_ PING -> e PING_ @@ -286,11 +275,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where FileCmd SFSender <$> case tag of FNEW_ | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP - | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSTMax <*> pure Nothing + | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSMaxTime <*> pure Nothing FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL - FTTL_ -> FTTL <$> _smpP <*> smpP FCT SFRecipient tag -> FileCmd SFRecipient <$> case tag of FGET_ -> FGET <$> _smpP @@ -315,7 +303,6 @@ data FileResponseTag = FRSndIds_ | FRRcvIds_ | FRFile_ - | FRFileTime_ | FROk_ | FRErr_ | FRPong_ @@ -326,7 +313,6 @@ instance Encoding FileResponseTag where FRSndIds_ -> "SIDS" FRRcvIds_ -> "RIDS" FRFile_ -> "FILE" - FRFileTime_ -> "TTL" FROk_ -> "OK" FRErr_ -> "ERR" FRPong_ -> "PONG" @@ -337,17 +323,15 @@ instance ProtocolMsgTag FileResponseTag where "SIDS" -> Just FRSndIds_ "RIDS" -> Just FRRcvIds_ "FILE" -> Just FRFile_ - "TTL" -> Just FRFileTime_ "OK" -> Just FROk_ "ERR" -> Just FRErr_ "PONG" -> Just FRPong_ _ -> Nothing data FileResponse - = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorage + = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorageTime | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey C.CbNonce - | FRFileTime GrantedStorage | FROk | FRErr XFTPErrorType | FRPong @@ -361,7 +345,6 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where | otherwise -> e (FRSndIds_, ' ', fId, rIds) FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) - FRFileTime gs -> e (FRFileTime_, ' ', gs) FROk -> e FROk_ FRErr err -> case err of BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH) @@ -374,10 +357,9 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where protocolP v = \case FRSndIds_ | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP - | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure GrantedPermanent + | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure (GSTExpires 0) FRRcvIds_ -> FRRcvIds <$> _smpP FRFile_ -> FRFile <$> _smpP <*> smpP - FRFileTime_ -> FRFileTime <$> _smpP FROk_ -> pure FROk FRErr_ -> FRErr <$> _smpP FRPong_ -> pure FRPong diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index fadbec358..6cf6861d4 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -32,7 +32,7 @@ import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust, isNothing) +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) @@ -480,7 +480,6 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case FDEL -> noFile =<< deleteServerFile fr FGET rDhKey -> sendServerFile fr rDhKey FACK -> noFile =<< ackFileReception fId fr - FTTL storageTime ep -> noFile =<< setFileTime fId storageTime ep -- it should never get to the commands below, they are passed in other constructors of XFTPRequest FNEW {} -> noFile $ FRErr INTERNAL PING -> noFile $ FRErr INTERNAL @@ -495,12 +494,12 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case unless (size file `elem` sizes) $ throwE SIZE ts <- liftIO getFileTime maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep - let (expiresAt, permanent, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime + let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts expiresAt permanent + sId <- ExceptT $ addFileRetry st file 3 ts expiresAt rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks lift $ withFileLog $ \sl -> do - logAddFile sl sId file ts expiresAt permanent EntityActive + logAddFile sl sId file ts expiresAt EntityActive logAddRecipients sl sId rcps stats <- asks serverStats lift $ incFileStat filesCreated @@ -508,17 +507,6 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case let rIds = L.map (\(FileRecipient rId _) -> rId) rcps pure $ FRSndIds sId rIds granted pure $ either FRErr id r - setFileTime :: XFTPFileId -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse - setFileTime sId storageTime ep = do - st <- asks fileStore - maxSeconds <- storageMaxSeconds (xftpTimeProofHeader sessionId sId) ep - now <- liftIO $ roundedSeconds <$> getSystemSeconds - let (expiresAt, permanent, granted) = resolveStorage now maxSeconds storageTime - liftIO (setFileExpiration st sId expiresAt permanent) >>= \case - Right () -> do - withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt permanent - pure $ FRFileTime granted - Left e -> pure $ FRErr e storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64) storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do @@ -527,12 +515,12 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case now <- liftIO getCurrentTime let Entitlement {entitlementName, expiresAt} = ent liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case - Just True | expiresAt > now -> pure $ fromMaybe defaultMax $ M.lookup entitlementName entCfg + Just True | expiresAt > now -> pure $ maybe defaultMax Just (M.lookup entitlementName entCfg) _ -> pure defaultMax - addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> M s (Either XFTPErrorType XFTPFileId) - addFileRetry st file n ts expiresAt permanent = + addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) + addFileRetry st file n ts expiresAt = retryAdd n $ \sId -> runExceptT $ do - ExceptT $ addFile st sId file ts expiresAt permanent EntityActive + ExceptT $ addFile st sId file ts expiresAt EntityActive pure sId addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = @@ -670,15 +658,14 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime -resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, Bool, GrantedStorage) -resolveStorage base maxSeconds storageTime = (expiresAt, permanent, granted) +resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorageTime) +resolveStorage base maxSeconds storageTime = (expiresAt, granted) where reqSeconds = case storageTime of - FSTMax -> maxSeconds - FSTFor hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds - permanent = isNothing reqSeconds + FSMaxTime -> maxSeconds + FSTime hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds - granted = maybe GrantedPermanent (\s -> GrantedExpires (base + s)) reqSeconds + granted = GSTExpires $ base + fromMaybe 0 reqSeconds expireServerFiles :: FileStoreClass s => Maybe Int -> M s () expireServerFiles itemDelay = diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 5d465a824..a24ec48bb 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -93,8 +93,8 @@ data XFTPServerConfig s = XFTPServerConfig controlPortAdminAuth :: Maybe BasicAuth, -- | time after which the files can be removed and check interval, seconds fileExpiration :: Maybe ExpirationConfig, - -- | maximum storage time per entitlement name, seconds; Nothing value is permanent - fileStorageEntitlements :: Map Text (Maybe Int64), + -- | maximum storage time per entitlement name, seconds + fileStorageEntitlements :: Map Text Int64, -- | timeout to receive file fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds @@ -173,10 +173,9 @@ defaultFileExpiration = checkInterval = 2 * 3600 -- seconds, 2 hours } -storageAtLeast :: Maybe Int64 -> Maybe Int64 -> Bool -storageAtLeast Nothing _ = True -storageAtLeast (Just _) Nothing = False -storageAtLeast (Just a) (Just b) = a >= b +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 diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 591b878e3..f9eb51242 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -442,11 +442,9 @@ cliCommandP cfgPath logPath iniFile = <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file")) ) -iniEntitlements :: Ini -> Map T.Text (Maybe Int64) +iniEntitlements :: Ini -> Map T.Text Int64 iniEntitlements ini = M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")] where readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini)) - parseMax t = case T.strip t of - "permanent" -> Just Nothing - s -> Just . (3600 *) <$> (readMaybe (T.unpack s) :: Maybe Int64) + 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 e8b01ece9..0291ab114 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -57,7 +57,6 @@ data FileRec = FileRec recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, expiresAt :: Maybe RoundedFileTime, - permanent :: Bool, fileStatus :: TVar ServerEntityStatus } @@ -80,9 +79,8 @@ class FileStoreClass s where type FileStoreConfig s newFileStore :: FileStoreConfig s -> IO s closeFileStore :: s -> IO () - addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> IO (Either XFTPErrorType ()) + addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ()) - setFileExpiration :: s -> SenderId -> Maybe RoundedFileTime -> Bool -> IO (Either XFTPErrorType ()) addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ()) deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ()) deleteFiles :: s -> [SenderId] -> IO () @@ -114,9 +112,9 @@ instance FileStoreClass STMFileStore where closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog - addFile STMFileStore {files} sId fileInfo createdAt expiresAt permanent status = atomically $ + addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $ ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo createdAt expiresAt permanent status + f <- newFileRec sId fileInfo createdAt expiresAt status TM.insert sId f files pure $ Right () @@ -131,11 +129,6 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - setFileExpiration STMFileStore {files} sId expiresAt permanent = atomically $ - TM.lookup sId files >>= \case - Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt, permanent = permanent} files - _ -> pure $ Left AUTH - addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withFile st senderId $ \FileRec {recipientIds} -> do rIds <- readTVar recipientIds @@ -180,9 +173,9 @@ instance FileStoreClass STMFileStore where expiredFiles STMFileStore {files} now defaultTtl _limit = do fs <- readTVarIO files - fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt, permanent}) -> + 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 not permanent && effExpiry < now + in if effExpiry < now then do path <- readTVarIO filePath pure $ Just (sId, path, size) @@ -197,12 +190,12 @@ instance FileStoreClass STMFileStore where -- Internal STM helpers -newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> STM FileRec -newFileRec senderId fileInfo createdAt expiresAt permanent status = do +newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec +newFileRec senderId fileInfo createdAt expiresAt status = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing fileStatus <- newTVar status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a) withFile STMFileStore {files} sId a = diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 61fbb4463..75a0b20dc 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -82,28 +82,23 @@ instance FileStoreClass PostgresFileStore where closeDBStore dbStore mapM_ closeStoreLog dbStoreLog - addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt permanent status = + addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addFile" st $ \db -> E.try ( DB.execute db - "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, permanent, status) VALUES (?,?,?,?,?,?,?,?)" - (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, permanent, status) + "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)" + (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status) ) >>= either handleDuplicate (pure . Right) - withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt permanent status + withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do assertUpdated $ withDB' "setFilePath" st $ \db -> DB.execute db "UPDATE files SET file_path = ? WHERE sender_id = ? AND file_path IS NULL AND status = 'active'" (fPath, sId) withLog "setFilePath" st $ \s -> logPutFile s sId fPath - setFileExpiration st sId expiresAt permanent = E.uninterruptibleMask_ $ runExceptT $ do - assertUpdated $ withDB' "setFileExpiration" st $ \db -> - DB.execute db "UPDATE files SET expires_at = ?, permanent = ? WHERE sender_id = ?" (expiresAt, permanent, sId) - withLog "setFileExpiration" st $ \s -> logSetFileExpiration s sId expiresAt permanent - addRecipient st senderId (FileRecipient rId rKey) = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addRecipient" st $ \db -> E.try @@ -136,13 +131,13 @@ instance FileStoreClass PostgresFileStore where getFile st party fId = runExceptT $ case party of SFSender -> do - row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, status FROM files WHERE sender_id = ?" + row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?" fr <- ExceptT $ rowToFileRec row pure (fr, sndKey (fileInfo fr)) SFRecipient -> do row :. Only rcpKeyBs <- loadFileRow - "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.permanent, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" + "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" fr <- ExceptT $ rowToFileRec row rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs pure (fr, rcpKey) @@ -161,7 +156,7 @@ instance FileStoreClass PostgresFileStore where fmap toResult $ withTransaction (dbStore st) $ \db -> DB.query db - "SELECT sender_id, file_path, file_size FROM files WHERE (NOT permanent AND expires_at < ?) OR (NOT permanent AND expires_at IS NULL AND created_at < ?) LIMIT ?" + "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) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] @@ -179,21 +174,21 @@ instance FileStoreClass PostgresFileStore where -- Internal helpers -mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> IO FileRec -mkFileRec senderId fileInfo path createdAt expiresAt permanent status = do +mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec +mkFileRec senderId fileInfo path createdAt expiresAt status = do filePath <- newTVarIO path recipientIds <- newTVarIO S.empty fileStatus <- newTVarIO status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} -type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, Bool, ServerEntityStatus) +type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec) -rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, permanent, status) = +rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) = case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - Right <$> mkFileRec sId fileInfo path createdAt expiresAt permanent status + Right <$> mkFileRec sId fileInfo path createdAt expiresAt status Left _ -> pure $ Left INTERNAL -- DB helpers @@ -248,7 +243,7 @@ importFileStore storeLogFilePath dbCfg = do fCnt <- withTransaction (dbStore pgStore) $ \db -> do DB.copy_ db - "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, status) FROM STDIN WITH (FORMAT csv)" + "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)" iforM_ (M.toList allFiles) $ \i (sId, fr) -> do DB.putCopyData db =<< fileRecToCSV sId fr when (i > 0 && i `mod` 10000 == 0) $ putStr (" " <> show i <> " files\r") >> hFlush stdout @@ -287,13 +282,13 @@ exportFileStore storeLogFilePath dbCfg = do !fCnt <- withTransaction (dbStore pgStore) $ \db -> DB.fold_ db - "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, status FROM files ORDER BY created_at" + "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at" (0 :: Int) - ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, permanent, status) -> + ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) -> case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - logAddFile sl sId fileInfo createdAt expiresAt permanent status + logAddFile sl sId fileInfo createdAt expiresAt status forM_ path $ logPutFile sl sId pure (fc + 1) Left _ -> do @@ -331,7 +326,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m () iforM_ xs f = zipWithM_ f [0 ..] xs fileRecToCSV :: SenderId -> FileRec -> IO ByteString -fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, permanent, fileStatus} = do +fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do path <- readTVarIO filePath status <- readTVarIO fileStatus pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n' @@ -344,7 +339,6 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, nullable (toField <$> path), renderField (toField createdAt), nullable (toField <$> expiresAt), - renderField (toField permanent), quotedField (toField status) ] diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs index 93ea84313..98122b523 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs @@ -51,14 +51,12 @@ m20260823_file_expiration :: Text m20260823_file_expiration = [r| ALTER TABLE files ADD COLUMN expires_at BIGINT; -ALTER TABLE files ADD COLUMN permanent BOOLEAN NOT NULL DEFAULT FALSE; -CREATE INDEX idx_files_expiry ON files (permanent, expires_at, created_at); +CREATE INDEX idx_files_expiry ON files (expires_at, created_at); |] down_m20260823_file_expiration :: Text down_m20260823_file_expiration = [r| DROP INDEX idx_files_expiry; -ALTER TABLE files DROP COLUMN permanent; ALTER TABLE files DROP COLUMN expires_at; |] diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index c4639f8ab..656d31904 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -12,7 +12,6 @@ module Simplex.FileTransfer.Server.StoreLog readWriteFileStore, writeFileStore, logAddFile, - logSetFileExpiration, logPutFile, logAddRecipients, logDeleteFile, @@ -43,26 +42,24 @@ import Simplex.Messaging.Util (bshow) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) Bool ServerEntityStatus + = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId | BlockFile SenderId BlockingInfo | AckFile RecipientId -- TODO add senderId as well? - | SetFileExpiration SenderId (Maybe RoundedFileTime) Bool deriving (Show) instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt expiresAt permanent status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> permExpE permanent expiresAt + AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> expE expiresAt PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) BlockFile sId info -> strEncode (Str "FBLK", sId, info) AckFile rId -> strEncode (Str "FACK", rId) - SetFileExpiration sId expiresAt permanent -> strEncode (Str "FTTL", sId) <> permExpE permanent expiresAt where - permExpE permanent expiresAt = " " <> (if permanent then "T" else "F") <> maybe "" ((" " <>) . strEncode) expiresAt + expE = maybe "" ((" " <>) . strEncode) strP = A.choice [ "FNEW " *> addFileP, @@ -70,8 +67,7 @@ instance StrEncoding FileStoreLogRecord where "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), "FBLK " *> (BlockFile <$> strP_ <*> strP), - "FACK " *> (AckFile <$> strP), - "FTTL " *> (setP <$> strP <*> permExpP) + "FACK " *> (AckFile <$> strP) ] where addFileP = do @@ -79,23 +75,14 @@ instance StrEncoding FileStoreLogRecord where file <- strP_ createdAt <- strP status <- _strP <|> pure EntityActive - (expiresAt, permanent) <- permExpP - pure $ AddFile sId file createdAt expiresAt permanent status - setP sId (expiresAt, permanent) = SetFileExpiration sId expiresAt permanent - permExpP = do - permanent <- (A.space *> permP) <|> pure False expiresAt <- (A.space *> (Just <$> strP)) <|> pure Nothing - pure (expiresAt, permanent) - permP = (True <$ A.char 'T') <|> (False <$ A.char 'F') + pure $ AddFile sId file createdAt expiresAt status logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> IO () -logAddFile s sId file createdAt expiresAt permanent status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt permanent status - -logSetFileExpiration :: StoreLog 'WriteMode -> SenderId -> Maybe RoundedFileTime -> Bool -> IO () -logSetFileExpiration s sId expiresAt permanent = logFileStoreRecord s $ SetFileExpiration sId expiresAt permanent +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO () +logAddFile s sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -125,15 +112,14 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s _ -> pure () addToStore = \case - AddFile sId file createdAt expiresAt permanent status - | size file > 0 -> addFile st sId file createdAt expiresAt permanent status + AddFile sId file createdAt expiresAt status + | size file > 0 -> addFile st sId file createdAt expiresAt status | otherwise -> pure $ Left SIZE PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId BlockFile sId info -> blockFile st sId info True AckFile rId -> ackFile st rId - SetFileExpiration sId expiresAt permanent -> setFileExpiration st sId expiresAt permanent addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () @@ -142,9 +128,9 @@ writeFileStore s STMFileStore {files, recipients} = do readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () - logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, fileStatus} = do + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus - logAddFile s senderId fileInfo createdAt expiresAt permanent status + logAddFile s senderId fileInfo createdAt expiresAt status (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 4b762b113..6593e36c8 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -196,13 +196,13 @@ instance ToField SndFileStatus where toField = toField . textEncode fileStorageTimeText :: FileStorageTime -> Text fileStorageTimeText = \case - FSTMax -> "max" - FSTFor h -> "for " <> T.pack (show h) + FSMaxTime -> "max" + FSTime h -> "for " <> T.pack (show h) fileStorageTimeParse :: Text -> Maybe FileStorageTime fileStorageTimeParse s = case T.words s of - ["max"] -> Just FSTMax - ["for", h] -> FSTFor <$> readMaybe (T.unpack h) + ["max"] -> Just FSMaxTime + ["for", h] -> FSTime <$> readMaybe (T.unpack h) _ -> Nothing instance ToField FileStorageTime where toField = toField . fileStorageTimeText diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 6ef64929b..f79ae3741 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -130,7 +130,6 @@ module Simplex.Messaging.Agent xftpSendFile, xftpSendFileStorage, xftpSendDescription, - xftpSetFileTime, xftpDeleteSndFileInternal, xftpDeleteSndFilesInternal, xftpDeleteSndFileRemote, @@ -190,9 +189,9 @@ import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) import Data.Traversable (mapAccumL) import Data.Word (Word16) -import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile', xftpSetFileTime') +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 (..), GrantedStorage) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client @@ -777,7 +776,7 @@ 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 FSTMax +xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSMaxTime {-# INLINE xftpSendFile #-} xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId @@ -789,11 +788,6 @@ xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient xftpSendDescription c = withAgentEnv c .:. xftpSendDescription' c {-# INLINE xftpSendDescription #-} --- | Set XFTP file storage time on the server (all chunks in the sender description) -xftpSetFileTime :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AE [GrantedStorage] -xftpSetFileTime c userId vfd storageTime credential = withAgentEnv c $ xftpSetFileTime' c userId vfd storageTime credential -{-# INLINE xftpSetFileTime #-} - -- | Delete XFTP snd file internally (deletes work files from file system and db records) xftpDeleteSndFileInternal :: AgentClient -> SndFileId -> IO () xftpDeleteSndFileInternal c = withAgentEnv' c . deleteSndFileInternal c diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 2d4bc5402..fb7b0dc72 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -94,7 +94,6 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, - agentXFTPSetChunkTime, agentCbDecrypt, cryptoError, sendAck, @@ -234,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, GrantedStorage, xftpNewProofHeader, xftpTimeProofHeader) +import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, FileStorageTime, 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 (..)) @@ -2222,19 +2221,6 @@ agentXFTPDeleteChunk :: AgentClient -> UserId -> DeletedSndChunkReplica -> AM () agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} = withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId -agentXFTPSetChunkTime :: AgentClient -> UserId -> XFTPServer -> ChunkReplicaId -> C.APrivateAuthKey -> FileDigest -> FileStorageTime -> Maybe EntitlementCredential -> AM GrantedStorage -agentXFTPSetChunkTime c userId server (ChunkReplicaId fId) replicaKey (FileDigest chunkDigest) storageTime credential = - withXFTPClient c (userId, server, chunkDigest) "FTTL" $ \xftp -> do - proof <- liftIO $ mkEntitlementTimeProof (sessionId $ X.thParams xftp) fId credential - X.setXFTPChunkTime xftp replicaKey fId storageTime proof - -mkEntitlementTimeProof :: SessionId -> SMP.SenderId -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof) -mkEntitlementTimeProof _ _ Nothing = pure Nothing -mkEntitlementTimeProof sessId sId (Just cred@EntitlementCredential {issuerKeyIdx}) = - case M.lookup issuerKeyIdx entitlementIssuerKeys of - Nothing -> pure Nothing - Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpTimeProofHeader sessId sId) - xftpRcvKeys :: Int -> AM (NonEmpty C.AAuthKeyPair) xftpRcvKeys n = do rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 157a03083..9f95f503d 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 FSTMax + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSMaxTime 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 FSTMax + Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSMaxTime 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 FSTMax + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSMaxTime updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] createSndFileReplica_ db 2 newSndChunkReplica1