From 4989bd8df6a9d4f0b9f8f030c60dc0572af191e8 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sat, 22 Aug 2026 21:15:11 +0000 Subject: [PATCH 01/19] xftp server: support storage time and BBS proofs of badge credential to extend it --- plans/2026-08-22-xftp-file-storage-time.md | 105 +++++++++++++++++++++ rfcs/2026-08-22-xftp-file-storage-time.md | 64 +++++++++++++ 2 files changed, 169 insertions(+) create mode 100644 plans/2026-08-22-xftp-file-storage-time.md create mode 100644 rfcs/2026-08-22-xftp-file-storage-time.md diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md new file mode 100644 index 000000000..fc617685e --- /dev/null +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -0,0 +1,105 @@ +# Implementation plan: XFTP variable file storage time + +Proposal: `../rfcs/2026-08-22-xftp-file-storage-time.md`. + +## simplexmq: entitlement crypto + +New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypto.BBS`: + +- `Entitlement {level :: Text, expiresAt :: UTCTime, extraInfo :: Text}` +- `EntitlementCredential` (issuer key index, holder secret, BBS signature, entitlement) +- `EntitlementProof` (issuer key index, presentation header, BBS proof, entitlement) +- the disclosed-message encoding: the holder secret is message 0 and stays undisclosed; `expiresAt`, `level`, and `extraInfo` are messages 1 to 3 and are disclosed +- the BBS header string `"SimpleX entitlement v1"`, the message count, and the disclosed indexes +- `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` +- `verifyEntitlement :: Map Int BBSPublicKey -> EntitlementProof -> IO (Maybe Bool)` +- the issuer public keys constant `Map Int BBSPublicKey` + +## simplexmq: protocol, new XFTP version + +In `Simplex.FileTransfer.Transport`: + +- add the next `VersionXFTP` and set `currentXFTPVersion` to 4 + +In `Simplex.FileTransfer.Protocol`: + +- add `FileStorageTime` and its encoding +- 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 + +In `Simplex.FileTransfer.Server`: + +- pass `sessionId` from `thParams` into `processXFTPRequest` + +## simplexmq: server configuration + +In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: + +- read a maximum storage time for each entitlement level, and a default maximum, from the INI file +- exit at startup if any level maximum is below the default +- read the issuer public keys from the shared constant + +## simplexmq: server store and expiration + +Common to both stores, in `Simplex.FileTransfer.Server.Store`: + +- add `expiresAt` to `FileRec` +- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the maximum from the level, set `expiresAt = now + min(requested, maximum)`, and return the expiration +- add the FTTL handler, which verifies the proof against `sessionId <> senderId`, sets `expiresAt = now + min(requested, maximum)`, and returns the expiration +- retain `created_at` for statistics and export + +STM store: + +- in `expiredFiles`, select files where `expiresAt < now` + +PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations: + +- add the column `expires_at BIGINT NOT NULL` +- add a migration for the column and the index `idx_files_expires_at` +- change the `expiredFiles` query to `WHERE expires_at < ? ORDER BY expires_at LIMIT ?` + +Store log, in `Simplex.FileTransfer.Server.StoreLog`: + +- add `expiresAt` to the `AddFile` record +- for older records without an expiration, default `expiresAt` to `createdAt + default storage time` + +## 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: + +- add a nullable entitlement credential column and a storage time column to `snd_files` +- add the migration to both stores +- in `createSndFile`, store the credential and the storage time + +Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: + +- in `agentXFTPNewChunk`, read the credential, the storage time, and the digest from the send record +- inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof +- discard the returned expiration for now + +Set-time: + +- for a completed file, generate a per-chunk proof bound to `sessionId <> senderId` 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` (`level = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent +- pass the user's credential and `FSTMax` to `xftpSendFile` +- retain the `maxXFTPFileSize` size limit +- reuse `verifyEntitlement` for peer-badge verification +- import the issuer public keys from the shared simplexmq constant + +## Order + +1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges. +2. Add `FileStorageTime`, the new XFTP version, the FNEW and FTTL protocol changes, and the responses. +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. +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 new file mode 100644 index 000000000..b0bad056c --- /dev/null +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -0,0 +1,64 @@ +# XFTP variable file storage time + +## 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. + +## Entitlement + +An entitlement is a level, an expiration, and an extra string: + +``` +data Entitlement = Entitlement + { level :: Text, + expiresAt :: UTCTime, + extraInfo :: Text + } +``` + +The entitlement is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server interprets `level` to select a maximum storage time and ignores `extraInfo`; interpretation of `extraInfo` is out of scope here. + +The protocol layers know only the entitlement, never a badge. Chat maps its own badge to an entitlement before it asks the agent to send. + +simplexmq defines the entitlement, its BBS proof generation and verification, the disclosed-message encoding, and the issuer public keys, in `Simplex.Messaging.Crypto.Entitlement`. The protocol form is `EntitlementProof` (the issuer key index, the presentation header, the BBS proof, and the entitlement). The signing form is `EntitlementCredential` (the issuer key index, the holder secret, the BBS signature, and the entitlement); the server never receives it. + +## Storage time + +``` +data FileStorageTime = FSTMax | FSTFor Word32 -- hours +``` + +`FSTFor` requests a specific number of hours. `FSTMax` requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. + +## Commands, new XFTP version + +FNEW gains a storage time and an optional entitlement proof: + +``` +FNEW FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof) +``` + +FTTL is a new `FileCommand FSender`, authorized with the sender key of `senderId`: + +``` +FTTL FileStorageTime (Maybe EntitlementProof) +``` + +FTTL sets the expiration to `now + min(requested, maximum)`. It may reduce the current expiration, since the sender can also delete the file. + +Each command binds its proof to a presentation header: + +- FNEW: `sessionId <> sndKey <> digest` +- FTTL: `sessionId <> senderId` + +Both commands return the granted expiration: FNEW extends the `FRSndIds` response with it, and FTTL uses a new response that returns it. + +Version 3 and earlier encode neither the storage time nor the proof, and the server applies the default storage time. `currentXFTPVersion` becomes 4. + +## Maximum storage time + +The server configures a maximum storage time for each entitlement level, and a default maximum for requests with no proof. The server exits at startup if any level maximum is below the default, so a proof never reduces the allowed time. The server treats an entitlement whose `expiresAt` has passed as no proof. + +## Binding + +The presentation header binds each proof to the TLS session and to the specific chunk. On FNEW the chunk is identified by the sender key and the digest, which the server already verifies for every later command on the file. On FTTL the chunk is identified by `senderId`, which the server has assigned by then. A proof generated for one session and chunk verifies for no other, which prevents reuse. From add65420c7027d8a4ed796b4abc896984d6fe401 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sat, 22 Aug 2026 22:14:47 +0000 Subject: [PATCH 02/19] update --- plans/2026-08-22-xftp-file-storage-time.md | 54 +++++++++++---- rfcs/2026-08-22-xftp-file-storage-time.md | 80 +++++++++++++++------- 2 files changed, 96 insertions(+), 38 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index fc617685e..4f8f1cdef 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -6,9 +6,34 @@ Proposal: `../rfcs/2026-08-22-xftp-file-storage-time.md`. New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypto.BBS`: -- `Entitlement {level :: Text, expiresAt :: UTCTime, extraInfo :: Text}` -- `EntitlementCredential` (issuer key index, holder secret, BBS signature, entitlement) -- `EntitlementProof` (issuer key index, presentation header, BBS proof, entitlement) +Types: + +``` +newtype EntitlementSecret = EntitlementSecret ByteString + +data Entitlement = Entitlement + { level :: Text, + expiresAt :: UTCTime, + extraInfo :: Text + } + +data EntitlementCredential = EntitlementCredential + { issuerKeyIdx :: Int, + holderSecret :: EntitlementSecret, + signature :: BBSSignature, + entitlement :: Entitlement + } + +data EntitlementProof = EntitlementProof + { issuerKeyIdx :: Int, + presHeader :: BBSPresHeader, + proof :: BBSProof, + entitlement :: Entitlement + } +``` + +Functions and constants: + - the disclosed-message encoding: the holder secret is message 0 and stays undisclosed; `expiresAt`, `level`, and `extraInfo` are messages 1 to 3 and are disclosed - the BBS header string `"SimpleX entitlement v1"`, the message count, and the disclosed indexes - `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` @@ -23,7 +48,12 @@ In `Simplex.FileTransfer.Transport`: In `Simplex.FileTransfer.Protocol`: -- add `FileStorageTime` and its encoding +- add `FileStorageTime` and its encoding: + +``` +data FileStorageTime = FSTMax | FSTFor Word32 -- FSTMax may resolve to permanent; FSTFor: hours +``` + - 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 @@ -36,7 +66,7 @@ In `Simplex.FileTransfer.Server`: In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: -- read a maximum storage time for each entitlement level, and a default maximum, from the INI file +- read a maximum storage time for each entitlement level, and a default maximum, from the INI file, where each maximum is a number of hours or permanent - exit at startup if any level maximum is below the default - read the issuer public keys from the shared constant @@ -44,24 +74,24 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: Common to both stores, in `Simplex.FileTransfer.Server.Store`: -- add `expiresAt` to `FileRec` -- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the maximum from the level, set `expiresAt = now + min(requested, maximum)`, and return the expiration -- add the FTTL handler, which verifies the proof against `sessionId <> senderId`, sets `expiresAt = now + min(requested, maximum)`, and returns the expiration +- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`, where `Nothing` is permanent storage +- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the level maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it +- add the FTTL handler, which verifies the proof against `sessionId <> senderId`, sets `expiresAt` by the same resolution, and returns it - retain `created_at` for statistics and export STM store: -- in `expiredFiles`, select files where `expiresAt < now` +- in `expiredFiles`, select files where `expiresAt` is `Just t` and `t < now` PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations: -- add the column `expires_at BIGINT NOT NULL` +- add the nullable column `expires_at BIGINT`, where `NULL` is permanent storage - add a migration for the column and the index `idx_files_expires_at` -- change the `expiredFiles` query to `WHERE expires_at < ? ORDER BY expires_at LIMIT ?` +- change the `expiredFiles` query to `WHERE expires_at < ? ORDER BY expires_at LIMIT ?` (a `NULL` expiration is excluded by the comparison) Store log, in `Simplex.FileTransfer.Server.StoreLog`: -- add `expiresAt` to the `AddFile` record +- add the optional expiration to the `AddFile` record, encoding permanent storage - for older records without an expiration, default `expiresAt` to `createdAt + default storage time` ## simplexmq: agent diff --git a/rfcs/2026-08-22-xftp-file-storage-time.md b/rfcs/2026-08-22-xftp-file-storage-time.md index b0bad056c..592e3fcc6 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -6,59 +6,87 @@ The server stores a storage time for each file. The sender sets it in the FNEW c ## Entitlement -An entitlement is a level, an expiration, and an extra string: +An entitlement is a level, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entLevel` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send. + +The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here. ``` -data Entitlement = Entitlement - { level :: Text, - expiresAt :: UTCTime, - extraInfo :: Text - } +entitlement = entLevel entExpires entExtra +entLevel = shortString ; e.g. "supporter", "legend" +entExpires = shortString ; expiration, encoded as signed +entExtra = shortString ; opaque, interpretation out of scope + +entitlementProof = issuerKeyIndex bbsProof entitlement +issuerKeyIndex = 2*2 OCTET ; Word16, network byte order +bbsProof = largeString ; BBS proof bytes ``` -The entitlement is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server interprets `level` to select a maximum storage time and ignores `extraInfo`; interpretation of `extraInfo` is out of scope here. - -The protocol layers know only the entitlement, never a badge. Chat maps its own badge to an entitlement before it asks the agent to send. - -simplexmq defines the entitlement, its BBS proof generation and verification, the disclosed-message encoding, and the issuer public keys, in `Simplex.Messaging.Crypto.Entitlement`. The protocol form is `EntitlementProof` (the issuer key index, the presentation header, the BBS proof, and the entitlement). The signing form is `EntitlementCredential` (the issuer key index, the holder secret, the BBS signature, and the entitlement); the server never receives it. +The presentation header that the BBS proof is generated over is not transmitted; the server reconstructs it from the command context (see [Binding](#binding)), which is what binds the proof. ## Storage time ``` -data FileStorageTime = FSTMax | FSTFor Word32 -- hours +fileStorageTime = storageMax / storageFor +storageMax = %s"M" +storageFor = %s"F" storageHours +storageHours = 4*4 OCTET ; Word32, network byte order ``` -`FSTFor` requests a specific number of hours. `FSTMax` requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. +`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. ## Commands, new XFTP version -FNEW gains a storage time and an optional entitlement proof: +The new protocol version extends FNEW and adds FTTL. ``` -FNEW FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof) +fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime optEntitlementProof +fttl = %s"FTTL " fileStorageTime optEntitlementProof +optEntitlementProof = %s"0" / (%s"1" entitlementProof) ``` -FTTL is a new `FileCommand FSender`, authorized with the sender key of `senderId`: +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. ``` -FTTL FileStorageTime (Maybe EntitlementProof) +sndIds = %s"SIDS " senderId rcvIds grantedStorage +fileTime = %s"TTL " grantedStorage +grantedStorage = grantedExpires / grantedPerm +grantedExpires = %s"F" expiresSeconds +grantedPerm = %s"P" +expiresSeconds = 8*8 OCTET ; Int64 seconds since epoch, network byte order ``` -FTTL sets the expiration to `now + min(requested, maximum)`. It may reduce the current expiration, since the sender can also delete the file. +`grantedExpires` returns the absolute expiration, and `grantedPerm` indicates permanent storage. `senderId` and `rcvIds` are defined by the current XFTP protocol. -Each command binds its proof to a presentation header: +## Binding -- FNEW: `sessionId <> sndKey <> digest` -- FTTL: `sessionId <> senderId` +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. -Both commands return the granted expiration: FNEW extends the `FRSndIds` response with it, and FTTL uses a new response that returns it. +``` +fnewPresHeader = sessionId sndKey digest +fttlPresHeader = sessionId senderId +``` -Version 3 and earlier encode neither the storage time nor the proof, and the server applies the default storage time. `currentXFTPVersion` becomes 4. +On FNEW the chunk is identified by the sender key and the digest, which the server verifies for every later command on the file. On FTTL the chunk is identified by `senderId`, which the server has assigned by then. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`. ## Maximum storage time -The server configures a maximum storage time for each entitlement level, and a default maximum for requests with no proof. The server exits at startup if any level maximum is below the default, so a proof never reduces the allowed time. The server treats an entitlement whose `expiresAt` has passed as no proof. +The server configures a maximum storage time for each entitlement level, 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 level 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. -## Binding +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 level maximum is permanent, and the finite maximum otherwise. + +## Encoding primitives + +``` +shortString = length *OCTET ; 0-255 bytes +largeString = length2 *OCTET +length = 1*1 OCTET +length2 = 2*2 OCTET ; Word16, network byte order +``` -The presentation header binds each proof to the TLS session and to the specific chunk. On FNEW the chunk is identified by the sender key and the digest, which the server already verifies for every later command on the file. On FTTL the chunk is identified by `senderId`, which the server has assigned by then. A proof generated for one session and chunk verifies for no other, which prevents reuse. +`senderId`, `rcvIds`, `fileInfo`, `sndKey`, `digest`, `rcvKeys`, `optBasicAuth`, and `sessionId` are defined by the current XFTP and SMP protocols. From 0df161a0021dac0bbe2dada985ad573917bb6f77 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 23 Aug 2026 15:14:17 +0000 Subject: [PATCH 03/19] types --- plans/2026-08-22-xftp-file-storage-time.md | 25 ++-- rfcs/2026-08-22-xftp-file-storage-time.md | 21 ++-- simplexmq.cabal | 1 + src/Simplex/Messaging/Crypto/Entitlement.hs | 129 ++++++++++++++++++++ 4 files changed, 152 insertions(+), 24 deletions(-) create mode 100644 src/Simplex/Messaging/Crypto/Entitlement.hs diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index 4f8f1cdef..406296c4c 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -9,24 +9,23 @@ New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypt Types: ``` -newtype EntitlementSecret = EntitlementSecret ByteString +newtype MasterKey = MasterKey ByteString data Entitlement = Entitlement - { level :: Text, + { entitlementName :: Text, expiresAt :: UTCTime, extraInfo :: Text } data EntitlementCredential = EntitlementCredential { issuerKeyIdx :: Int, - holderSecret :: EntitlementSecret, - signature :: BBSSignature, + masterKey :: MasterKey, + issuerSignature :: BBSSignature, entitlement :: Entitlement } data EntitlementProof = EntitlementProof { issuerKeyIdx :: Int, - presHeader :: BBSPresHeader, proof :: BBSProof, entitlement :: Entitlement } @@ -34,10 +33,10 @@ data EntitlementProof = EntitlementProof Functions and constants: -- the disclosed-message encoding: the holder secret is message 0 and stays undisclosed; `expiresAt`, `level`, and `extraInfo` are messages 1 to 3 and are disclosed +- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed - the BBS header string `"SimpleX entitlement v1"`, the message count, and the disclosed indexes - `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` -- `verifyEntitlement :: Map Int BBSPublicKey -> EntitlementProof -> IO (Maybe Bool)` +- `verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it) - the issuer public keys constant `Map Int BBSPublicKey` ## simplexmq: protocol, new XFTP version @@ -66,8 +65,8 @@ In `Simplex.FileTransfer.Server`: In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: -- read a maximum storage time for each entitlement level, and a default maximum, from the INI file, where each maximum is a number of hours or permanent -- exit at startup if any level maximum is below the default +- 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 the issuer public keys from the shared constant ## simplexmq: server store and expiration @@ -75,8 +74,8 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: Common to both stores, in `Simplex.FileTransfer.Server.Store`: - add `expiresAt :: Maybe RoundedFileTime` to `FileRec`, where `Nothing` is permanent storage -- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the level maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it -- add the FTTL handler, which verifies the proof against `sessionId <> senderId`, sets `expiresAt` by the same resolution, and returns it +- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the entitlement's maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it +- add the FTTL handler, which verifies the proof against `sessionId <> sndKey <> digest`, sets `expiresAt` by the same resolution, and returns it - retain `created_at` for statistics and export STM store: @@ -115,12 +114,12 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: Set-time: -- for a completed file, generate a per-chunk proof bound to `sessionId <> senderId` and send FTTL, authorized with the sender key +- 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` (`level = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent +- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent - pass the user's credential and `FSTMax` to `xftpSendFile` - retain the `maxXFTPFileSize` size limit - reuse `verifyEntitlement` for peer-badge verification diff --git a/rfcs/2026-08-22-xftp-file-storage-time.md b/rfcs/2026-08-22-xftp-file-storage-time.md index 592e3fcc6..5f6884770 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -6,13 +6,13 @@ The server stores a storage time for each file. The sender sets it in the FNEW c ## Entitlement -An entitlement is a level, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entLevel` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send. +An entitlement is a name, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entName` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send. The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here. ``` -entitlement = entLevel entExpires entExtra -entLevel = shortString ; e.g. "supporter", "legend" +entitlement = entName entExpires entExtra +entName = shortString ; e.g. "supporter", "legend" entExpires = shortString ; expiration, encoded as signed entExtra = shortString ; opaque, interpretation out of scope @@ -56,29 +56,28 @@ FNEW extends the SIDS response with the granted storage, and FTTL adds a respons sndIds = %s"SIDS " senderId rcvIds grantedStorage fileTime = %s"TTL " grantedStorage grantedStorage = grantedExpires / grantedPerm -grantedExpires = %s"F" expiresSeconds +grantedExpires = %s"F" expiresAt grantedPerm = %s"P" -expiresSeconds = 8*8 OCTET ; Int64 seconds since epoch, network byte order +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. ## 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. +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. ``` -fnewPresHeader = sessionId sndKey digest -fttlPresHeader = sessionId senderId +presHeader = sessionId sndKey digest ``` -On FNEW the chunk is identified by the sender key and the digest, which the server verifies for every later command on the file. On FTTL the chunk is identified by `senderId`, which the server has assigned by then. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`. +The chunk is identified by the sender key and the digest, which the server verifies for every command on the file. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`. ## Maximum storage time -The server configures a maximum storage time for each entitlement level, 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 level 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 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. -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 level 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. `storageMax` yields permanent storage when the entitlement's maximum is permanent, and the finite maximum otherwise. ## Encoding primitives diff --git a/simplexmq.cabal b/simplexmq.cabal index db6c0f31d..12eac0e7f 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -135,6 +135,7 @@ library Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet Simplex.Messaging.Crypto.BBS + Simplex.Messaging.Crypto.Entitlement Simplex.Messaging.Crypto.SNTRUP761 Simplex.Messaging.Crypto.SNTRUP761.Bindings Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs new file mode 100644 index 000000000..106bb4683 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | A generic entitlement, proven with a BBS proof over the SHA-256 suite. +-- The holder secret (the master key) is the undisclosed message; the name, the +-- expiration, and the extra string are disclosed. The protocol and the server +-- reference the entitlement, never a badge; chat maps its own badge to an +-- entitlement. +module Simplex.Messaging.Crypto.Entitlement + ( Entitlement (..), + EntitlementCredential (..), + EntitlementProof (..), + MasterKey (..), + entitlementIssuerKeys, + signEntitlement, + verifyCredential, + generateEntitlementProof, + verifyEntitlement, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as JQ +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Either (fromRight) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON) + +newtype MasterKey = MasterKey ByteString + deriving newtype (Eq, Show, StrEncoding) + deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey) + +-- | The disclosed content of an entitlement proof. +data Entitlement = Entitlement + { entitlementName :: Text, + expiresAt :: UTCTime, + extraInfo :: Text + } + deriving (Eq, Show) + +-- | The signing form, held by the entitlement holder; never transmitted. +data EntitlementCredential = EntitlementCredential + { issuerKeyIdx :: Int, + masterKey :: MasterKey, + issuerSignature :: BBSSignature, + entitlement :: Entitlement + } + deriving (Eq, Show) + +-- | The proof form. The presentation header is not part of the proof: the +-- verifier supplies it, so a proof cannot claim its own binding. +data EntitlementProof = EntitlementProof + { issuerKeyIdx :: Int, + proof :: BBSProof, + entitlement :: Entitlement + } + deriving (Eq, Show) + +entitlementBBSHeader :: BBSHeader +entitlementBBSHeader = BBSHeader "SimpleX entitlement v1" + +entitlementMessageCount :: Int +entitlementMessageCount = 4 + +entitlementDisclosedIndexes :: [Int] +entitlementDisclosedIndexes = [1, 2, 3] + +entitlementMessages :: MasterKey -> Entitlement -> [ByteString] +entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent + +disclosedMessages :: Entitlement -> [ByteString] +disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} = + [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] + +-- | Issuer side: sign an entitlement for a holder master key. +signEntitlement :: BBSSecretKey -> Int -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) +signEntitlement sk keyIdx mk ent = + fmap (\sig -> EntitlementCredential keyIdx mk sig ent) <$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) + +-- | Holder side: verify the credential received from the issuer. +verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool +verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} = + bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement) + +-- | Holder side: generate a proof bound to the presentation header. +generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof) +generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = + fmap (\p -> EntitlementProof issuerKeyIdx p entitlement) <$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) + +-- | Verifier side: verify the proof with the configured key its index points to, +-- against the supplied presentation header. Nothing means the key index is not +-- among the configured keys. +verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) +verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, proof, entitlement} = case M.lookup issuerKeyIdx keys of + Nothing -> pure Nothing + Just pk -> Just <$> bbsProofVerify pk proof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) + +entitlementIssuerKeys :: Map Int BBSPublicKey +entitlementIssuerKeys = + M.fromList + [ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"), + (2, key "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"), + (3, key "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"), + (4, key "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"), + (5, key "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"), + (6, key "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"), + (7, key "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"), + (8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd") + ] + where + key = fromRight (error "bad base64 in entitlement issuer key") . strDecode . B.pack + +$(JQ.deriveJSON defaultJSON ''Entitlement) + +$(JQ.deriveJSON defaultJSON ''EntitlementCredential) + +$(JQ.deriveJSON defaultJSON ''EntitlementProof) From c08946214db5c3e944fceb34421f96c3011b4777 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Mon, 24 Aug 2026 20:52:57 +0000 Subject: [PATCH 04/19] implementation --- simplexmq.cabal | 2 + src/Simplex/FileTransfer/Agent.hs | 31 ++++--- src/Simplex/FileTransfer/Client.hs | 26 +++++- src/Simplex/FileTransfer/Protocol.hs | 81 +++++++++++++++--- src/Simplex/FileTransfer/Server.hs | 82 +++++++++++++------ src/Simplex/FileTransfer/Server/Env.hs | 24 ++++-- src/Simplex/FileTransfer/Server/Main.hs | 17 +++- src/Simplex/FileTransfer/Server/Store.hs | 33 +++++--- .../FileTransfer/Server/Store/Postgres.hs | 46 ++++++----- .../Server/Store/Postgres/Migrations.hs | 18 +++- src/Simplex/FileTransfer/Server/StoreLog.hs | 41 +++++++--- src/Simplex/FileTransfer/Transport.hs | 6 +- src/Simplex/FileTransfer/Types.hs | 30 ++++++- src/Simplex/Messaging/Agent.hs | 18 +++- src/Simplex/Messaging/Agent/Client.hs | 32 +++++++- .../Messaging/Agent/Store/AgentStore.hs | 19 +++-- .../Agent/Store/Postgres/Migrations/App.hs | 4 +- .../M20260823_snd_files_entitlement.hs | 21 +++++ .../Agent/Store/SQLite/Migrations/App.hs | 4 +- .../M20260823_snd_files_entitlement.hs | 20 +++++ src/Simplex/Messaging/Crypto/BBS.hs | 5 ++ src/Simplex/Messaging/Crypto/Entitlement.hs | 17 ++++ tests/AgentTests/SQLiteTests.hs | 6 +- tests/CoreTests/CryptoTests.hs | 24 ++++++ tests/XFTPClient.hs | 1 + 25 files changed, 486 insertions(+), 122 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 12eac0e7f..2fce56fbd 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -193,6 +193,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -246,6 +247,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement Simplex.Messaging.Agent.Store.SQLite.Util if flag(client_postgres) || flag(server_postgres) exposed-modules: diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a8b220327..b3a157da3 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -22,6 +22,7 @@ module Simplex.FileTransfer.Agent -- Sending files xftpSendFile', xftpSendDescription', + xftpSetFileTime', deleteSndFileInternal, deleteSndFilesInternal, deleteSndFileRemote, @@ -54,7 +55,7 @@ import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize) import Simplex.FileTransfer.Crypto import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage, SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -68,6 +69,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store.AgentStore import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.Lazy as LC @@ -350,8 +352,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m () notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) -xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId -xftpSendFile' c userId file numRecipients = do +xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId +xftpSendFile' c userId file numRecipients credential storageTime = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath @@ -359,7 +361,7 @@ xftpSendFile' c userId file numRecipients = do key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing credential storageTime lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -375,7 +377,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect) key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest} + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing FSTMax lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -405,7 +407,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do prepareFile _ SndFile {prefixPath = Nothing} = throwE $ INTERNAL "no prefix path" prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do - SndFile {numRecipients, chunks} <- + SndFile {numRecipients, chunks, entitlementCredential, storageTime} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath @@ -424,7 +426,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - srvs <- forM pendingChunks $ createChunk numRecipients' + srvs <- forM pendingChunks $ createChunk numRecipients' entitlementCredential storageTime let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -454,8 +456,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of [] -> Left ch SndFileChunkReplica {server} : _ -> Right server - createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP) - createChunk numRecipients' ch = do + createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk numRecipients' credential storageTime ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica @@ -482,7 +484,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId when deleted $ throwE $ FILE NO_FILE withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do - replica <- agentXFTPNewChunk c ch numRecipients' srvAuth + replica <- agentXFTPNewChunk c ch numRecipients' srvAuth credential storageTime pure (replica, srvAuth) sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () @@ -639,6 +641,15 @@ 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 a5cd4acfe..151725d4d 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -20,6 +20,8 @@ module Simplex.FileTransfer.Client xftpClientServer, xftpTransportHost, createXFTPChunk, + createXFTPChunkStorage, + setXFTPChunkTime, addXFTPRecipients, uploadXFTPChunk, downloadXFTPChunk, @@ -57,6 +59,7 @@ import Network.Socket (HostName) import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Client ( NetworkConfig (..), NetworkRequestMode (..), @@ -254,9 +257,26 @@ createXFTPChunk :: NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rcps auth_ = - sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case - (FRSndIds sId rIds, body) -> noFile body (sId, rIds) +createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSTMax Nothing + +createXFTPChunkStorage :: + XFTPClient -> + C.APrivateAuthKey -> + FileInfo -> + NonEmpty C.APublicAuthKey -> + Maybe BasicAuth -> + FileStorageTime -> + Maybe EntitlementProof -> + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) +createXFTPChunkStorage 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 + +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) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 763142c72..75abd14aa 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -22,6 +22,10 @@ module Simplex.FileTransfer.Protocol FileCommand (..), FileCmd (..), FileInfo (..), + FileStorageTime (..), + GrantedStorage (..), + xftpNewProofHeader, + xftpTimeProofHeader, XFTPFileId, FileResponse (..), xftpBlockSize, @@ -38,14 +42,17 @@ import qualified Data.Aeson.TH as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) -import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub) +import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub) import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..)) +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers @@ -77,7 +84,7 @@ import Simplex.Messaging.Protocol tEncodeBatch1, tParse, ) -import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..)) +import Simplex.Messaging.Transport (SessionId, THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Util ((<$?>)) xftpBlockSize :: Int @@ -123,6 +130,7 @@ 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 @@ -137,6 +145,7 @@ instance FilePartyI p => Encoding (FileCommandTag p) where FADD_ -> "FADD" FPUT_ -> "FPUT" FDEL_ -> "FDEL" + FTTL_ -> "FTTL" FGET_ -> "FGET" FACK_ -> "FACK" PING_ -> "PING" @@ -152,6 +161,7 @@ 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_ @@ -175,10 +185,11 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where {-# INLINE protocolError #-} data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender 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 @@ -196,15 +207,50 @@ data FileInfo = FileInfo } deriving (Show) +data FileStorageTime = FSTMax | FSTFor Word32 + deriving (Eq, Show) + +instance Encoding FileStorageTime where + smpEncode = \case + FSTMax -> "M" + FSTFor hours -> smpEncode ('F', hours) + smpP = + smpP >>= \case + 'M' -> pure FSTMax + 'F' -> FSTFor <$> smpP + _ -> fail "bad FileStorageTime" + +data GrantedStorage = GrantedExpires Int64 | GrantedPermanent + 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 + smpEncode = \case + GrantedExpires t -> smpEncode ('F', t) + GrantedPermanent -> "P" + smpP = + smpP >>= \case + 'F' -> GrantedExpires <$> smpP + 'P' -> pure GrantedPermanent + _ -> fail "bad GrantedStorage" + type XFTPFileId = EntityId instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p - encodeProtocol _v = \case - FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_) + encodeProtocol v = \case + FNEW file rKeys auth_ st ep + | v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep) + | otherwise -> e (FNEW_, ' ', file, rKeys, auth_) 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_ @@ -235,13 +281,16 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where type Tag FileCmd = FileCmdTag encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c - protocolP _v = \case + protocolP v = \case FCT SFSender tag -> FileCmd SFSender <$> case tag of - FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP + FNEW_ + | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP + | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSTMax <*> 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 @@ -266,6 +315,7 @@ data FileResponseTag = FRSndIds_ | FRRcvIds_ | FRFile_ + | FRFileTime_ | FROk_ | FRErr_ | FRPong_ @@ -276,6 +326,7 @@ instance Encoding FileResponseTag where FRSndIds_ -> "SIDS" FRRcvIds_ -> "RIDS" FRFile_ -> "FILE" + FRFileTime_ -> "TTL" FROk_ -> "OK" FRErr_ -> "ERR" FRPong_ -> "PONG" @@ -286,15 +337,17 @@ 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) + = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorage | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey C.CbNonce + | FRFileTime GrantedStorage | FROk | FRErr XFTPErrorType | FRPong @@ -303,9 +356,12 @@ data FileResponse instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where type Tag FileResponse = FileResponseTag encodeProtocol v = \case - FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) + FRSndIds fId rIds gs + | v >= fileStorageTimeXFTPVersion -> e (FRSndIds_, ' ', fId, rIds, gs) + | otherwise -> e (FRSndIds_, ' ', fId, rIds) FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) + FRFileTime gs -> e (FRFileTime_, ' ', gs) FROk -> e FROk_ FRErr err -> case err of BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH) @@ -315,10 +371,13 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where e :: Encoding a => a -> ByteString e = smpEncode - protocolP _v = \case - FRSndIds_ -> FRSndIds <$> _smpP <*> smpP + protocolP v = \case + FRSndIds_ + | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP + | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure GrantedPermanent 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 9f7499782..085656ed4 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -30,6 +30,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map.Strict as M import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T @@ -54,6 +55,8 @@ import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPresHeader) +import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), entitlementIssuerKeys, verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -125,7 +128,7 @@ data Handshake xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do - mapM_ (expireServerFiles Nothing) fileExpiration + when (isJust fileExpiration) $ expireServerFiles Nothing restoreServerStats raceAny_ ( runServer @@ -252,7 +255,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let interval = checkInterval expCfg * 1000000 forever $ do liftIO $ threadDelay' interval - expireServerFiles (Just 100000) expCfg + expireServerFiles (Just 100000) serverStatsThread_ :: XFTPServerConfig s -> [M s ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -401,9 +404,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea | otherwise = case xftpDecodeTServer thParams bodyHead of Right (Right t@(_, _, (corrId, fId, _))) -> do - let THandleParams {thAuth} = thParams + let THandleParams {thAuth, sessionId} = thParams verifyXFTPTransmission thAuth t >>= \case - VRVerified req -> uncurry send =<< processXFTPRequest body req + VRVerified req -> uncurry send =<< processXFTPRequest sessionId body req VRFailed e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) @@ -443,7 +446,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = case cmd of - FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file + FileCmd SFSender (FNEW file rcps auth' st ep) -> pure $ XFTPReqNew file rcps auth' st ep `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -464,9 +467,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH -processXFTPRequest :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) -processXFTPRequest HTTP2Body {bodyPart} = \case - XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH) +processXFTPRequest :: forall s. FileStoreClass s => SessionId -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) +processXFTPRequest sessionId HTTP2Body {bodyPart} = \case + XFTPReqNew file rks auth storageTime ep -> noFile =<< ifM allowNew (createFile file rks storageTime ep) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -477,35 +480,59 @@ processXFTPRequest 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 XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse - createFile file rks = do + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> 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 + maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep + let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts + 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 EntityActive + logAddFile sl sId file ts expiresAt EntityActive logAddRecipients sl sId rcps stats <- asks serverStats lift $ incFileStat filesCreated liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks) let rIds = L.map (\(FileRecipient rId _) -> rId) rcps - pure $ FRSndIds sId rIds + pure $ FRSndIds sId rIds granted pure $ either FRErr id r - addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) - addFileRetry st file n ts = + 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, granted) = resolveStorage now maxSeconds storageTime + liftIO (setFileExpiration st sId expiresAt) >>= \case + Right () -> do + withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt + 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 + entCfg <- asks $ fileStorageEntitlements . config + defaultMax <- asks $ fmap ttl . fileExpiration . config + 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 + _ -> pure defaultMax + addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) + addFileRetry st file n ts expiresAt = retryAdd n $ \sId -> runExceptT $ do - ExceptT $ addFile st sId file ts EntityActive + ExceptT $ addFile st sId file ts expiresAt EntityActive pure sId addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = @@ -643,21 +670,30 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime -expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s () -expireServerFiles itemDelay expCfg = do +resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorage) +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 + expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds + granted = maybe GrantedPermanent (\(RoundedSystemTime t) -> GrantedExpires t) expiresAt + +expireServerFiles :: FileStoreClass s => Maybe Int -> M s () +expireServerFiles itemDelay = do st <- asks fileStore us <- asks usedStorage usedStart <- readTVarIO us - old <- liftIO $ expireBeforeEpoch expCfg + now <- liftIO $ roundedSeconds <$> getSystemSeconds filesCount <- liftIO $ getFileCount st logNote $ "Expiration check: " <> tshow filesCount <> " files" - expireLoop st us old + expireLoop st us now usedEnd <- readTVarIO us logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." where mbs bs = tshow (bs `div` 1048576) <> "mb" - expireLoop st us old = do - expired <- liftIO $ expiredFiles st old 10000 + expireLoop st us now = do + expired <- liftIO $ expiredFiles st now 10000 forM_ expired $ \(sId, filePath_, fileSize) -> do mapM_ threadDelay itemDelay forM_ filePath_ $ \fp -> @@ -670,7 +706,7 @@ expireServerFiles itemDelay expCfg = do unless (null sIds) $ do withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds liftIO $ deleteFiles st sIds - expireLoop st us old + expireLoop st us now 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 b816eb36b..5d465a824 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -37,12 +37,16 @@ import Control.Monad import Crypto.Random import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Word (Word32) import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T -import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) +import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId) +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) @@ -89,6 +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), -- | timeout to receive file fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds @@ -160,9 +166,6 @@ fromFileStore = \case #endif {-# INLINE fromFileStore #-} -defFileExpirationHours :: Int64 -defFileExpirationHours = 48 - defaultFileExpiration :: ExpirationConfig defaultFileExpiration = ExpirationConfig @@ -170,8 +173,17 @@ 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 + newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) -newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do +newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do + let defaultMax = ttl <$> fileExpiration + unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ do + logError "STORE: entitlement storage time is below the default file expiration" + exitFailure random <- C.newRandom (store, storeLog) <- case serverStoreCfg of XSCMemory storeLogPath -> do @@ -196,7 +208,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCre pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 070dc546f..591b878e3 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Simplex.FileTransfer.Server.Main @@ -16,11 +17,13 @@ module Simplex.FileTransfer.Server.Main import Control.Monad (unless, when) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Ini (lookupValue, readIniFile) +import Data.Ini (Ini, lookupValue, readIniFile) import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.List (find) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -291,6 +294,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do 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 = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini @@ -437,3 +441,12 @@ cliCommandP cfgPath logPath iniFile = ( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database")) <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file")) ) + +iniEntitlements :: Ini -> Map T.Text (Maybe 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) diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 66d19d6de..e124953ac 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -16,6 +16,7 @@ module Simplex.FileTransfer.Server.Store STMFileStore (..), RoundedFileTime, fileTimePrecision, + defFileExpirationHours, ) where @@ -55,6 +56,7 @@ data FileRec = FileRec filePath :: TVar (Maybe FilePath), recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, + expiresAt :: Maybe RoundedFileTime, fileStatus :: TVar ServerEntityStatus } @@ -63,6 +65,9 @@ type RoundedFileTime = RoundedSystemTime 3600 fileTimePrecision :: Int64 fileTimePrecision = 3600 +defFileExpirationHours :: Int64 +defFileExpirationHours = 48 + data FileRecipient = FileRecipient RecipientId C.APublicAuthKey deriving (Show) @@ -74,8 +79,9 @@ class FileStoreClass s where type FileStoreConfig s newFileStore :: FileStoreConfig s -> IO s closeFileStore :: s -> IO () - addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) + addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ()) + setFileExpiration :: s -> SenderId -> Maybe RoundedFileTime -> IO (Either XFTPErrorType ()) addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ()) deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ()) deleteFiles :: s -> [SenderId] -> IO () @@ -107,9 +113,9 @@ instance FileStoreClass STMFileStore where closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog - addFile STMFileStore {files} sId fileInfo createdAt status = atomically $ + addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $ ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo createdAt status + f <- newFileRec sId fileInfo createdAt expiresAt status TM.insert sId f files pure $ Right () @@ -124,6 +130,11 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH + setFileExpiration STMFileStore {files} sId expiresAt = atomically $ + TM.lookup sId files >>= \case + Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt} files + _ -> pure $ Left AUTH + addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withFile st senderId $ \FileRec {recipientIds} -> do rIds <- readTVar recipientIds @@ -166,14 +177,14 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - expiredFiles STMFileStore {files} old _limit = do + expiredFiles STMFileStore {files} now _limit = do fs <- readTVarIO files - fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) -> - if createdAt + fileTimePrecision < old - then do + fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, expiresAt}) -> + case expiresAt of + Just (RoundedSystemTime t) | t < now -> do path <- readTVarIO filePath pure $ Just (sId, path, size) - else pure Nothing + _ -> pure Nothing getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files where @@ -184,12 +195,12 @@ instance FileStoreClass STMFileStore where -- Internal STM helpers -newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec -newFileRec senderId fileInfo createdAt status = do +newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec +newFileRec senderId fileInfo createdAt expiresAt status = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing fileStatus <- newTVar status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a) withFile STMFileStore {files} sId a = diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 3b1bee05d..87b579a9d 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -82,23 +82,28 @@ instance FileStoreClass PostgresFileStore where closeDBStore dbStore mapM_ closeStoreLog dbStoreLog - addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt status = + addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addFile" st $ \db -> E.try ( DB.execute db - "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, status) VALUES (?,?,?,?,?,?)" - (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, status) + "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)" + (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status) ) >>= either handleDuplicate (pure . Right) - withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt status + withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do assertUpdated $ withDB' "setFilePath" st $ \db -> 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 = E.uninterruptibleMask_ $ runExceptT $ do + assertUpdated $ withDB' "setFileExpiration" st $ \db -> + DB.execute db "UPDATE files SET expires_at = ? WHERE sender_id = ?" (expiresAt, sId) + withLog "setFileExpiration" st $ \s -> logSetFileExpiration s sId expiresAt + addRecipient st senderId (FileRecipient rId rKey) = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addRecipient" st $ \db -> E.try @@ -131,13 +136,13 @@ instance FileStoreClass PostgresFileStore where getFile st party fId = runExceptT $ case party of SFSender -> do - row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files WHERE sender_id = ?" + row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?" fr <- ExceptT $ rowToFileRec row pure (fr, sndKey (fileInfo fr)) SFRecipient -> do row :. Only rcpKeyBs <- loadFileRow - "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" + "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" fr <- ExceptT $ rowToFileRec row rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs pure (fr, rcpKey) @@ -152,12 +157,12 @@ instance FileStoreClass PostgresFileStore where DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId) withLog "ackFile" st $ \s -> logAckFile s rId - expiredFiles st old limit = + expiredFiles st now limit = fmap toResult $ withTransaction (dbStore st) $ \db -> DB.query db - "SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?" - (fileTimePrecision, old, limit) + "SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? ORDER BY expires_at LIMIT ?" + (now, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) @@ -174,21 +179,21 @@ instance FileStoreClass PostgresFileStore where -- Internal helpers -mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> ServerEntityStatus -> IO FileRec -mkFileRec senderId fileInfo path createdAt status = do +mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec +mkFileRec senderId fileInfo path createdAt expiresAt status = do filePath <- newTVarIO path recipientIds <- newTVarIO S.empty fileStatus <- newTVarIO status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} -type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, ServerEntityStatus) +type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec) -rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, status) = +rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) = case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - Right <$> mkFileRec sId fileInfo path createdAt status + Right <$> mkFileRec sId fileInfo path createdAt expiresAt status Left _ -> pure $ Left INTERNAL -- DB helpers @@ -243,7 +248,7 @@ importFileStore storeLogFilePath dbCfg = do fCnt <- withTransaction (dbStore pgStore) $ \db -> do DB.copy_ db - "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, status) FROM STDIN WITH (FORMAT csv)" + "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)" iforM_ (M.toList allFiles) $ \i (sId, fr) -> do DB.putCopyData db =<< fileRecToCSV sId fr when (i > 0 && i `mod` 10000 == 0) $ putStr (" " <> show i <> " files\r") >> hFlush stdout @@ -282,13 +287,13 @@ exportFileStore storeLogFilePath dbCfg = do !fCnt <- withTransaction (dbStore pgStore) $ \db -> DB.fold_ db - "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files ORDER BY created_at" + "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at" (0 :: Int) - ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, status) -> + ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) -> case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - logAddFile sl sId fileInfo createdAt status + logAddFile sl sId fileInfo createdAt expiresAt status forM_ path $ logPutFile sl sId pure (fc + 1) Left _ -> do @@ -326,7 +331,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m () iforM_ xs f = zipWithM_ f [0 ..] xs fileRecToCSV :: SenderId -> FileRec -> IO ByteString -fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, fileStatus} = do +fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do path <- readTVarIO filePath status <- readTVarIO fileStatus pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n' @@ -338,6 +343,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, renderField (toField (Binary (C.encodePubKey sndKey))), nullable (toField <$> path), renderField (toField createdAt), + nullable (toField <$> expiresAt), quotedField (toField status) ] diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs index 5e84f97e7..89130d93a 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs @@ -14,7 +14,8 @@ import Text.RawString.QQ (r) xftpSchemaMigrations :: [(String, Text, Maybe Text)] xftpSchemaMigrations = - [ ("20260325_initial", m20260325_initial, Nothing) + [ ("20260325_initial", m20260325_initial, Nothing), + ("20260823_file_expiration", m20260823_file_expiration, Just down_m20260823_file_expiration) ] -- | The list of migrations in ascending order by date @@ -45,3 +46,18 @@ CREATE TABLE recipients ( CREATE INDEX idx_recipients_sender_id ON recipients (sender_id); CREATE INDEX idx_files_created_at ON files (created_at); |] + +m20260823_file_expiration :: Text +m20260823_file_expiration = + [r| +ALTER TABLE files ADD COLUMN expires_at BIGINT; +UPDATE files SET expires_at = created_at + 48 * 3600; +CREATE INDEX idx_files_expires_at ON files (expires_at); +|] + +down_m20260823_file_expiration :: Text +down_m20260823_file_expiration = + [r| +DROP INDEX idx_files_expires_at; +ALTER TABLE files DROP COLUMN expires_at; +|] diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 48ebb175e..4ee83f38e 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -12,6 +12,7 @@ module Simplex.FileTransfer.Server.StoreLog readWriteFileStore, writeFileStore, logAddFile, + logSetFileExpiration, logPutFile, logAddRecipients, logDeleteFile, @@ -26,7 +27,7 @@ import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Composition ((.:), (.::)) +import Data.Composition ((.:)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -38,41 +39,58 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.SystemTime (RoundedSystemTime (..)) import Simplex.Messaging.Util (bshow) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus + = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId | BlockFile SenderId BlockingInfo | AckFile RecipientId -- TODO add senderId as well? + | SetFileExpiration SenderId (Maybe RoundedFileTime) deriving (Show) instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) + AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> " " <> maybe "P" strEncode 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 -> strEncode (Str "FTTL", sId) <> " " <> maybe "P" strEncode expiresAt strP = A.choice - [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)), + [ "FNEW " *> addFileP, "FPUT " *> (PutFile <$> strP_ <*> strP), "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), "FBLK " *> (BlockFile <$> strP_ <*> strP), - "FACK " *> (AckFile <$> strP) + "FACK " *> (AckFile <$> strP), + "FTTL " *> (SetFileExpiration <$> strP_ <*> expiryP) ] + where + addFileP = do + sId <- strP_ + file <- strP_ + createdAt <- strP + status <- _strP <|> pure EntityActive + expiresAt <- (A.space *> expiryP) <|> pure (Just $ legacyExpiry createdAt) + pure $ AddFile sId file createdAt expiresAt status + expiryP = (Nothing <$ A.char 'P') <|> (Just <$> strP) + legacyExpiry (RoundedSystemTime c) = RoundedSystemTime (c + defFileExpirationHours * 3600) logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO () -logAddFile s = logFileStoreRecord s .:: AddFile +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO () +logAddFile s sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status + +logSetFileExpiration :: StoreLog 'WriteMode -> SenderId -> Maybe RoundedFileTime -> IO () +logSetFileExpiration s sId expiresAt = logFileStoreRecord s $ SetFileExpiration sId expiresAt logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -102,14 +120,15 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s _ -> pure () addToStore = \case - AddFile sId file createdAt status - | size file > 0 -> addFile st sId file createdAt status + AddFile sId file createdAt expiresAt status + | size file > 0 -> addFile st sId file createdAt expiresAt status | otherwise -> pure $ Left SIZE PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId BlockFile sId info -> blockFile st sId info True AckFile rId -> ackFile st rId + SetFileExpiration sId expiresAt -> setFileExpiration st sId expiresAt addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () @@ -118,9 +137,9 @@ writeFileStore s STMFileStore {files, recipients} = do readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () - logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus - logAddFile s senderId fileInfo createdAt status + logAddFile s senderId fileInfo createdAt expiresAt status (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index d55b25148..24fa3e13c 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -12,6 +12,7 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, authCmdsXFTPVersion, blockedFilesXFTPVersion, + fileStorageTimeXFTPVersion, xftpClientHandshakeStub, alpnSupportedXFTPhandshakes, xftpALPNv1, @@ -97,8 +98,11 @@ authCmdsXFTPVersion = VersionXFTP 2 blockedFilesXFTPVersion :: VersionXFTP blockedFilesXFTPVersion = VersionXFTP 3 +fileStorageTimeXFTPVersion :: VersionXFTP +fileStorageTimeXFTPVersion = VersionXFTP 4 + currentXFTPVersion :: VersionXFTP -currentXFTPVersion = VersionXFTP 3 +currentXFTPVersion = VersionXFTP 4 supportedFileServerVRange :: VersionRangeXFTP supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ff70b8f13..4b762b113 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -29,16 +29,21 @@ module Simplex.FileTransfer.Types sndChunkSize, ) where +import qualified Data.Aeson as JD import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word32) +import 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 import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -167,7 +172,9 @@ data SndFile = SndFile prefixPath :: Maybe FilePath, status :: SndFileStatus, deleted :: Bool, - redirect :: Maybe RedirectFileInfo + redirect :: Maybe RedirectFileInfo, + entitlementCredential :: Maybe EntitlementCredential, + storageTime :: FileStorageTime } deriving (Show) @@ -187,6 +194,25 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode instance ToField SndFileStatus where toField = toField . textEncode +fileStorageTimeText :: FileStorageTime -> Text +fileStorageTimeText = \case + FSTMax -> "max" + FSTFor 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) + _ -> 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) + instance TextEncoding SndFileStatus where textDecode = \case "new" -> Just SFSNew diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 979704fd3..6ef64929b 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -128,7 +128,9 @@ module Simplex.Messaging.Agent xftpDeleteRcvFile, xftpDeleteRcvFiles, xftpSendFile, + xftpSendFileStorage, xftpSendDescription, + xftpSetFileTime, xftpDeleteSndFileInternal, xftpDeleteSndFilesInternal, xftpDeleteSndFileRemote, @@ -188,9 +190,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') +import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile', xftpSetFileTime') import Simplex.FileTransfer.Description (ValidFileDescription) -import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client @@ -211,6 +213,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo) import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -774,14 +777,23 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c -- | Send XFTP file xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId -xftpSendFile c = withAgentEnv c .:. xftpSendFile' c +xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSTMax {-# INLINE xftpSendFile #-} +xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId +xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime +{-# INLINE xftpSendFileStorage #-} + -- | Send XFTP file xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId 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 45e7695b8..2d4bc5402 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -94,6 +94,7 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, + agentXFTPSetChunkTime, agentCbDecrypt, cryptoError, sendAck, @@ -233,7 +234,7 @@ import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb) -import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) +import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, FileStorageTime, GrantedStorage, xftpNewProofHeader, xftpTimeProofHeader) import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..)) @@ -253,6 +254,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.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client @@ -2186,17 +2188,26 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se g <- asks random withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec -agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> FileStorageTime -> AM NewSndChunkReplica +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) credential storageTime = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (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 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 @@ -2211,6 +2222,19 @@ 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/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 04fbcf729..19baa394b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -309,8 +309,9 @@ import Network.Socket (ServiceName) import qualified Network.TLS as TLS import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..)) import Simplex.FileTransfer.Types +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) import Simplex.Messaging.Agent.Stats @@ -3424,13 +3425,13 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) -createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) + "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, entitlement_credential, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3466,7 +3467,7 @@ getSndFile db sndFileId = runExceptT $ do DB.query db ( [sql| - SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest + SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, entitlement_credential, storage_time FROM snd_files WHERE snd_file_id = ? |] @@ -3476,12 +3477,12 @@ getSndFile db sndFileId = runExceptT $ do ) (Only sndFileId) where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) = + toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe EntitlementCredential, FileStorageTime) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, entitlementCredential, storageTime, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs index 1997b5c2a..de6e3f182 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -14,6 +14,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -27,7 +28,8 @@ schemaMigrations = ("20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) + ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc), + ("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement) ] -- | The list of migrations in ascending order by date 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 new file mode 100644 index 000000000..50b517c1a --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260823_snd_files_entitlement :: Text +m20260823_snd_files_entitlement = + [r| +ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; +ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; +|] + +down_m20260823_snd_files_entitlement :: Text +down_m20260823_snd_files_entitlement = + [r| +ALTER TABLE snd_files DROP COLUMN storage_time; +ALTER TABLE snd_files DROP COLUMN entitlement_credential; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs index 69cc74cfe..3585f42c2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -99,7 +100,8 @@ schemaMigrations = ("m20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("m20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) + ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc), + ("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement) ] -- | The list of migrations in ascending order by date 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 new file mode 100644 index 000000000..859786ebb --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260823_snd_files_entitlement :: Query +m20260823_snd_files_entitlement = + [sql| +ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; +ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; + |] + +down_m20260823_snd_files_entitlement :: Query +down_m20260823_snd_files_entitlement = + [sql| +ALTER TABLE snd_files DROP COLUMN storage_time; +ALTER TABLE snd_files DROP COLUMN entitlement_credential; + |] diff --git a/src/Simplex/Messaging/Crypto/BBS.hs b/src/Simplex/Messaging/Crypto/BBS.hs index 7b19ca004..332124d36 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -33,6 +33,7 @@ import Data.Proxy (Proxy (..)) import Foreign import Foreign.C import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) +import Simplex.Messaging.Encoding (Encoding (..), Large (..)) import Simplex.Messaging.Encoding.String import System.IO.Unsafe (unsafePerformIO) @@ -106,6 +107,10 @@ instance StrEncoding BBSProof where then pure (BBSProof bs) else fail $ "BBS: invalid proof length " <> show len +instance Encoding BBSProof where + smpEncode (BBSProof p) = smpEncode (Large p) + smpP = (\(Large p) -> BBSProof p) <$> smpP + -- FFI data BBS_Ciphersuite diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 106bb4683..529589a5c 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -34,7 +34,9 @@ import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Word (Word16) import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) @@ -68,6 +70,21 @@ data EntitlementProof = EntitlementProof } deriving (Eq, Show) +instance Encoding Entitlement where + smpEncode Entitlement {entitlementName, expiresAt, extraInfo} = + smpEncode (entitlementName, strEncode expiresAt, extraInfo) + smpP = do + (name, expBs, extra) <- smpP + expiresAt <- either fail pure $ strDecode (expBs :: ByteString) + pure Entitlement {entitlementName = name, expiresAt, extraInfo = extra} + +instance Encoding EntitlementProof where + smpEncode EntitlementProof {issuerKeyIdx, proof, entitlement} = + smpEncode (fromIntegral issuerKeyIdx :: Word16, proof, entitlement) + smpP = do + (idx, proof, entitlement) <- smpP + pure EntitlementProof {issuerKeyIdx = fromIntegral (idx :: Word16), proof, entitlement} + entitlementBBSHeader :: BBSHeader entitlementBBSHeader = BBSHeader "SimpleX entitlement v1" diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6aea60ff3..157a03083 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 + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax 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 + Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] -- Can't test it with strict tables -- createSndFileReplica_ db 1 newSndChunkReplica1 -- DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1" -- create file 2 - Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] createSndFileReplica_ db 2 newSndChunkReplica1 diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index a7cf4f9ba..635b4ebf6 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -13,7 +13,10 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isLeft, isRight) import Data.Int (Int64) +import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE @@ -25,6 +28,7 @@ import qualified SMPClient import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Crypto.Entitlement import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode) @@ -119,6 +123,8 @@ cryptoTests = do it "should produce unlinkable proofs" testBBSUnlinkable it "should produce proof of expected size" testBBSProofSize it "should roundtrip JSON and reject wrong-length input" testBBSJSON + describe "Entitlement" $ do + it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip instance Eq C.APublicKey where C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of @@ -444,3 +450,21 @@ testBBSJSON = do -- FromJSON must reject wrong-length input (regression: StrJSON length validation) (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing + +testEntitlementRoundtrip :: IO () +testEntitlementRoundtrip = do + Right (pk, sk) <- bbsKeyGen + let keys = M.singleton 1 pk + mk = MasterKey (B.replicate 32 '\7') + ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""} + ph = BBSPresHeader "session-id + snd-key + digest" + Right cred <- signEntitlement sk 1 mk ent + verifyCredential pk cred `shouldReturn` True + Right proof <- generateEntitlementProof pk cred ph + verifyEntitlement keys ph proof `shouldReturn` Just True + -- a different presentation header does not verify (session/chunk binding) + verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` Just False + -- an unknown issuer key index yields Nothing + verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` Nothing + -- the protocol encoding of the proof roundtrips + smpDecode (smpEncode proof) `shouldBe` Right proof diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index b306ae39c..d8280ef6e 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -182,6 +182,7 @@ testXFTPServerConfig = controlPortAdminAuth = Nothing, controlPortUserAuth = Nothing, fileExpiration = Just defaultFileExpiration, + fileStorageEntitlements = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, xftpCredentials = From fddc151ae04568f6806c6f07ea2de395d9059277 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Wed, 26 Aug 2026 10:41:32 +0000 Subject: [PATCH 05/19] update --- plans/2026-08-22-xftp-file-storage-time.md | 21 ++++--- src/Simplex/FileTransfer/Server.hs | 56 ++++++++++--------- src/Simplex/FileTransfer/Server/Store.hs | 36 ++++++------ .../FileTransfer/Server/Store/Postgres.hs | 47 ++++++++-------- .../Server/Store/Postgres/Migrations.hs | 7 ++- src/Simplex/FileTransfer/Server/StoreLog.hs | 43 +++++++------- 6 files changed, 113 insertions(+), 97 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index 406296c4c..ae0d5fd08 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -71,26 +71,29 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: ## 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. + Common to both stores, in `Simplex.FileTransfer.Server.Store`: -- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`, where `Nothing` is permanent storage -- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the entitlement's maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it -- add the FTTL handler, which verifies the proof against `sessionId <> sndKey <> digest`, sets `expiresAt` by the same resolution, and returns it -- retain `created_at` for statistics and export +- 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` +- retain `created_at` for statistics, export, and the default-expiry fallback STM store: -- in `expiredFiles`, select files where `expiresAt` is `Just t` and `t < now` +- in `expiredFiles`, expire a file when `not permanent && 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`, where `NULL` is permanent storage -- add a migration for the column and the index `idx_files_expires_at` -- change the `expiredFiles` query to `WHERE expires_at < ? ORDER BY expires_at LIMIT ?` (a `NULL` expiration is excluded by the comparison) +- 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. Store log, in `Simplex.FileTransfer.Server.StoreLog`: -- add the optional expiration to the `AddFile` record, encoding permanent storage +- 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` ## simplexmq: agent diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 085656ed4..fadbec358 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) +import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) @@ -495,12 +495,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, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime + let (expiresAt, permanent, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts expiresAt + sId <- ExceptT $ addFileRetry st file 3 ts expiresAt permanent rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks lift $ withFileLog $ \sl -> do - logAddFile sl sId file ts expiresAt EntityActive + logAddFile sl sId file ts expiresAt permanent EntityActive logAddRecipients sl sId rcps stats <- asks serverStats lift $ incFileStat filesCreated @@ -513,10 +513,10 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case st <- asks fileStore maxSeconds <- storageMaxSeconds (xftpTimeProofHeader sessionId sId) ep now <- liftIO $ roundedSeconds <$> getSystemSeconds - let (expiresAt, granted) = resolveStorage now maxSeconds storageTime - liftIO (setFileExpiration st sId expiresAt) >>= \case + let (expiresAt, permanent, granted) = resolveStorage now maxSeconds storageTime + liftIO (setFileExpiration st sId expiresAt permanent) >>= \case Right () -> do - withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt + withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt permanent pure $ FRFileTime granted Left e -> pure $ FRErr e storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64) @@ -529,10 +529,10 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case Just True | 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 = + addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> M s (Either XFTPErrorType XFTPFileId) + addFileRetry st file n ts expiresAt permanent = retryAdd n $ \sId -> runExceptT $ do - ExceptT $ addFile st sId file ts expiresAt EntityActive + ExceptT $ addFile st sId file ts expiresAt permanent EntityActive pure sId addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = @@ -670,30 +670,34 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime -resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorage) -resolveStorage base maxSeconds storageTime = (expiresAt, granted) +resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, Bool, GrantedStorage) +resolveStorage base maxSeconds storageTime = (expiresAt, permanent, 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 expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds - granted = maybe GrantedPermanent (\(RoundedSystemTime t) -> GrantedExpires t) expiresAt + granted = maybe GrantedPermanent (\s -> GrantedExpires (base + s)) reqSeconds expireServerFiles :: FileStoreClass s => Maybe Int -> M s () -expireServerFiles itemDelay = 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 - usedEnd <- readTVarIO us - logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." +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." where mbs bs = tshow (bs `div` 1048576) <> "mb" - expireLoop st us now = do - expired <- liftIO $ expiredFiles st now 10000 + expireLoop st us now defaultTtl = do + expired <- liftIO $ expiredFiles st now defaultTtl 10000 forM_ expired $ \(sId, filePath_, fileSize) -> do mapM_ threadDelay itemDelay forM_ filePath_ $ \fp -> @@ -706,7 +710,7 @@ expireServerFiles itemDelay = do unless (null sIds) $ do withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds liftIO $ deleteFiles st sIds - expireLoop st us now + expireLoop st us now defaultTtl randomId :: Int -> M s ByteString randomId n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index e124953ac..e8b01ece9 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -57,6 +57,7 @@ data FileRec = FileRec recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, expiresAt :: Maybe RoundedFileTime, + permanent :: Bool, fileStatus :: TVar ServerEntityStatus } @@ -79,9 +80,9 @@ class FileStoreClass s where type FileStoreConfig s newFileStore :: FileStoreConfig s -> IO s closeFileStore :: s -> IO () - addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) + addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> IO (Either XFTPErrorType ()) setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ()) - setFileExpiration :: s -> SenderId -> Maybe RoundedFileTime -> 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 () @@ -90,7 +91,7 @@ class FileStoreClass s where deleteRecipient :: s -> RecipientId -> FileRec -> IO () getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey)) ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ()) - expiredFiles :: s -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] + expiredFiles :: s -> Int64 -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] getUsedStorage :: s -> IO Int64 getFileCount :: s -> IO Int @@ -113,9 +114,9 @@ instance FileStoreClass STMFileStore where closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog - addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $ + addFile STMFileStore {files} sId fileInfo createdAt expiresAt permanent status = atomically $ ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo createdAt expiresAt status + f <- newFileRec sId fileInfo createdAt expiresAt permanent status TM.insert sId f files pure $ Right () @@ -130,9 +131,9 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - setFileExpiration STMFileStore {files} sId expiresAt = atomically $ + setFileExpiration STMFileStore {files} sId expiresAt permanent = atomically $ TM.lookup sId files >>= \case - Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt} files + Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt, permanent = permanent} files _ -> pure $ Left AUTH addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ @@ -177,14 +178,15 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - expiredFiles STMFileStore {files} now _limit = do + expiredFiles STMFileStore {files} now defaultTtl _limit = do fs <- readTVarIO files - fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, expiresAt}) -> - case expiresAt of - Just (RoundedSystemTime t) | t < now -> do - path <- readTVarIO filePath - pure $ Just (sId, path, size) - _ -> pure Nothing + fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt, permanent}) -> + let effExpiry = maybe (createdAt + defaultTtl) roundedSeconds expiresAt + in if not permanent && effExpiry < now + then do + path <- readTVarIO filePath + pure $ Just (sId, path, size) + else pure Nothing getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files where @@ -195,12 +197,12 @@ instance FileStoreClass STMFileStore where -- Internal STM helpers -newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec -newFileRec senderId fileInfo createdAt expiresAt status = do +newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> STM FileRec +newFileRec senderId fileInfo createdAt expiresAt permanent status = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing fileStatus <- newTVar status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, 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 87b579a9d..61fbb4463 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -82,27 +82,27 @@ instance FileStoreClass PostgresFileStore where closeDBStore dbStore mapM_ closeStoreLog dbStoreLog - addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status = + addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt permanent 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, status) VALUES (?,?,?,?,?,?,?)" - (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status) + "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) ) >>= either handleDuplicate (pure . Right) - withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status + withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt permanent 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 = E.uninterruptibleMask_ $ runExceptT $ do + setFileExpiration st sId expiresAt permanent = E.uninterruptibleMask_ $ runExceptT $ do assertUpdated $ withDB' "setFileExpiration" st $ \db -> - DB.execute db "UPDATE files SET expires_at = ? WHERE sender_id = ?" (expiresAt, sId) - withLog "setFileExpiration" st $ \s -> logSetFileExpiration s sId expiresAt + 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 -> @@ -136,13 +136,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, status FROM files WHERE sender_id = ?" + row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, 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.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.permanent, 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) @@ -157,12 +157,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 limit = + expiredFiles st now defaultTtl limit = fmap toResult $ withTransaction (dbStore st) $ \db -> DB.query db - "SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? ORDER BY expires_at LIMIT ?" - (now, limit) + "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 ?" + (now, now - defaultTtl, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) @@ -179,21 +179,21 @@ instance FileStoreClass PostgresFileStore where -- Internal helpers -mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec -mkFileRec senderId fileInfo path createdAt expiresAt status = do +mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> Bool -> ServerEntityStatus -> IO FileRec +mkFileRec senderId fileInfo path createdAt expiresAt permanent status = do filePath <- newTVarIO path recipientIds <- newTVarIO S.empty fileStatus <- newTVarIO status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, fileStatus} -type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) +type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, Bool, ServerEntityStatus) rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec) -rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) = +rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, permanent, status) = case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - Right <$> mkFileRec sId fileInfo path createdAt expiresAt status + Right <$> mkFileRec sId fileInfo path createdAt expiresAt permanent status Left _ -> pure $ Left INTERNAL -- DB helpers @@ -248,7 +248,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, status) FROM STDIN WITH (FORMAT csv)" + "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, 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 +287,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, status FROM files ORDER BY created_at" + "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, permanent, status FROM files ORDER BY created_at" (0 :: Int) - ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) -> + ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, permanent, status) -> case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - logAddFile sl sId fileInfo createdAt expiresAt status + logAddFile sl sId fileInfo createdAt expiresAt permanent status forM_ path $ logPutFile sl sId pure (fc + 1) Left _ -> do @@ -331,7 +331,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, fileStatus} = do +fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, permanent, fileStatus} = do path <- readTVarIO filePath status <- readTVarIO fileStatus pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n' @@ -344,6 +344,7 @@ 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 89130d93a..93ea84313 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs @@ -51,13 +51,14 @@ m20260823_file_expiration :: Text m20260823_file_expiration = [r| ALTER TABLE files ADD COLUMN expires_at BIGINT; -UPDATE files SET expires_at = created_at + 48 * 3600; -CREATE INDEX idx_files_expires_at ON files (expires_at); +ALTER TABLE files ADD COLUMN permanent BOOLEAN NOT NULL DEFAULT FALSE; +CREATE INDEX idx_files_expiry ON files (permanent, expires_at, created_at); |] down_m20260823_file_expiration :: Text down_m20260823_file_expiration = [r| -DROP INDEX idx_files_expires_at; +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 4ee83f38e..c4639f8ab 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -39,29 +39,30 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog -import Simplex.Messaging.SystemTime (RoundedSystemTime (..)) import Simplex.Messaging.Util (bshow) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus + = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) Bool ServerEntityStatus | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId | BlockFile SenderId BlockingInfo | AckFile RecipientId -- TODO add senderId as well? - | SetFileExpiration SenderId (Maybe RoundedFileTime) + | SetFileExpiration SenderId (Maybe RoundedFileTime) Bool deriving (Show) instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> " " <> maybe "P" strEncode expiresAt + AddFile sId file createdAt expiresAt permanent status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> permExpE permanent 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 -> strEncode (Str "FTTL", sId) <> " " <> maybe "P" strEncode expiresAt + SetFileExpiration sId expiresAt permanent -> strEncode (Str "FTTL", sId) <> permExpE permanent expiresAt + where + permExpE permanent expiresAt = " " <> (if permanent then "T" else "F") <> maybe "" ((" " <>) . strEncode) expiresAt strP = A.choice [ "FNEW " *> addFileP, @@ -70,7 +71,7 @@ instance StrEncoding FileStoreLogRecord where "FDEL " *> (DeleteFile <$> strP), "FBLK " *> (BlockFile <$> strP_ <*> strP), "FACK " *> (AckFile <$> strP), - "FTTL " *> (SetFileExpiration <$> strP_ <*> expiryP) + "FTTL " *> (setP <$> strP <*> permExpP) ] where addFileP = do @@ -78,19 +79,23 @@ instance StrEncoding FileStoreLogRecord where file <- strP_ createdAt <- strP status <- _strP <|> pure EntityActive - expiresAt <- (A.space *> expiryP) <|> pure (Just $ legacyExpiry createdAt) - pure $ AddFile sId file createdAt expiresAt status - expiryP = (Nothing <$ A.char 'P') <|> (Just <$> strP) - legacyExpiry (RoundedSystemTime c) = RoundedSystemTime (c + defFileExpirationHours * 3600) + (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') logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO () -logAddFile s sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status +logAddFile :: 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 -> IO () -logSetFileExpiration s sId expiresAt = logFileStoreRecord s $ SetFileExpiration sId expiresAt +logSetFileExpiration :: StoreLog 'WriteMode -> SenderId -> Maybe RoundedFileTime -> Bool -> IO () +logSetFileExpiration s sId expiresAt permanent = logFileStoreRecord s $ SetFileExpiration sId expiresAt permanent logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -120,15 +125,15 @@ 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 status - | size file > 0 -> addFile st sId file createdAt expiresAt status + AddFile sId file createdAt expiresAt permanent status + | size file > 0 -> addFile st sId file createdAt expiresAt permanent 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 -> setFileExpiration st sId expiresAt + SetFileExpiration sId expiresAt permanent -> setFileExpiration st sId expiresAt permanent addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () @@ -137,9 +142,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, fileStatus} = do + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, permanent, fileStatus} = do status <- readTVarIO fileStatus - logAddFile s senderId fileInfo createdAt expiresAt status + logAddFile s senderId fileInfo createdAt expiresAt permanent 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 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 06/19] 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 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 07/19] 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 From 83accac0bb5244d89c6ab9809a36c0d6904a9e78 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 19:19:50 +0000 Subject: [PATCH 08/19] refactor --- src/Simplex/Messaging/Agent.hs | 9 ++------- src/Simplex/Messaging/Crypto/BBS.hs | 2 +- tests/XFTPAgent.hs | 2 +- tests/XFTPClient.hs | 3 +++ tests/XFTPWebTests.hs | 4 ++-- 5 files changed, 9 insertions(+), 11 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 4423014bd..d6fe750e5 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -128,7 +128,6 @@ module Simplex.Messaging.Agent xftpDeleteRcvFile, xftpDeleteRcvFiles, xftpSendFile, - xftpSendFileStorage, xftpSendDescription, xftpDeleteSndFileInternal, xftpDeleteSndFilesInternal, @@ -775,14 +774,10 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c {-# INLINE xftpDeleteRcvFiles #-} -- | Send XFTP file -xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId -xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing Nothing +xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId +xftpSendFile c = withAgentEnv c .::. xftpSendFile' c {-# INLINE xftpSendFile #-} -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 #-} - -- | Send XFTP file xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId xftpSendDescription c = withAgentEnv c .:. xftpSendDescription' c diff --git a/src/Simplex/Messaging/Crypto/BBS.hs b/src/Simplex/Messaging/Crypto/BBS.hs index 332124d36..45c83e6f1 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -109,7 +109,7 @@ instance StrEncoding BBSProof where instance Encoding BBSProof where smpEncode (BBSProof p) = smpEncode (Large p) - smpP = (\(Large p) -> BBSProof p) <$> smpP + smpP = BBSProof . unLarge <$> smpP -- FFI diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 3d22d41d3..eed1d469d 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -30,7 +30,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..)) import Simplex.FileTransfer.Server.Store (STMFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) -import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers) +import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv) diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 5e8651d30..d694cf271 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -19,6 +19,7 @@ import Simplex.FileTransfer.Server (runXFTPServerBlocking) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), AFStoreType (..), defaultFileExpiration, defaultInactiveClientExpiration) import Simplex.FileTransfer.Server.Store (FileStoreClass, SFSType (..), STMFileStore) import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange) +import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server @@ -32,6 +33,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) #endif +xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing Nothing + data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s) updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index 0172a6dc7..4e0592222 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -46,9 +46,9 @@ import Test.Hspec hiding (fit, it) import Util import Simplex.FileTransfer.Server.Env (XFTPServerConfig) import Simplex.FileTransfer.Server.Store (STMFileStore) -import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort) +import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpSendFile, xftpTestPort) import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent) -import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers) +import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers) import Simplex.Messaging.Agent.Protocol (AEvent (..)) import SMPAgentClient (agentCfg, initAgentServers, testDB) import XFTPCLI (recipientFiles, senderFiles, testBracket) From 3aad15611403dc0555dc48c254f8a66623cbaa28 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 20:00:26 +0000 Subject: [PATCH 09/19] refactor --- src/Simplex/Messaging/Agent/Client.hs | 12 +++++++----- src/Simplex/Messaging/Crypto/Entitlement.hs | 7 ++++--- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 97e04d056..8bf16ac36 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -2195,14 +2195,16 @@ 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 $ 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) + proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} + where + mkEntitlementProof sessId sndKey = + pure (credential >>= \cred@EntitlementCredential {issuerKeyIdx} -> (cred,) <$> M.lookup issuerKeyIdx entitlementIssuerKeys) $>>= \(cred, pk) -> + generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest) >>= \case + Right p -> pure $ Just p + Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 529589a5c..a3bb28ecf 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -24,6 +24,7 @@ module Simplex.Messaging.Crypto.Entitlement ) where +import Control.Monad (forM) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as JQ import Data.ByteString.Char8 (ByteString) @@ -120,9 +121,9 @@ generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issu -- against the supplied presentation header. Nothing means the key index is not -- among the configured keys. verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) -verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, proof, entitlement} = case M.lookup issuerKeyIdx keys of - Nothing -> pure Nothing - Just pk -> Just <$> bbsProofVerify pk proof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) +verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, proof, entitlement} = + forM (M.lookup issuerKeyIdx keys) $ \pk -> + bbsProofVerify pk proof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) entitlementIssuerKeys :: Map Int BBSPublicKey entitlementIssuerKeys = From 121628a39b70175518cfdfa758a5e32cf733521b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 27 Aug 2026 21:07:44 +0100 Subject: [PATCH 10/19] simplify --- src/Simplex/Messaging/Agent/Client.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 8bf16ac36..682cfd999 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -2201,8 +2201,10 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} where mkEntitlementProof sessId sndKey = - pure (credential >>= \cred@EntitlementCredential {issuerKeyIdx} -> (cred,) <$> M.lookup issuerKeyIdx entitlementIssuerKeys) $>>= \(cred, pk) -> - generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest) >>= \case + pure credential + $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) entitlementIssuerKeys) + $>>= \pk -> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest) + >>= \case Right p -> pure $ Just p Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) From 46bb52db6a48ca89314c85311e285ee2eec70abf Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 27 Aug 2026 21:18:29 +0100 Subject: [PATCH 11/19] simplify --- src/Simplex/Messaging/Crypto/Entitlement.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index a3bb28ecf..125ebc057 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -40,6 +40,7 @@ import Simplex.Messaging.Crypto.BBS import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Util ((<$$>)) newtype MasterKey = MasterKey ByteString deriving newtype (Eq, Show, StrEncoding) @@ -57,8 +58,8 @@ data Entitlement = Entitlement data EntitlementCredential = EntitlementCredential { issuerKeyIdx :: Int, masterKey :: MasterKey, - issuerSignature :: BBSSignature, - entitlement :: Entitlement + entitlement :: Entitlement, + issuerSignature :: BBSSignature } deriving (Eq, Show) @@ -66,8 +67,8 @@ data EntitlementCredential = EntitlementCredential -- verifier supplies it, so a proof cannot claim its own binding. data EntitlementProof = EntitlementProof { issuerKeyIdx :: Int, - proof :: BBSProof, - entitlement :: Entitlement + entitlement :: Entitlement, + proof :: BBSProof } deriving (Eq, Show) @@ -75,9 +76,9 @@ instance Encoding Entitlement where smpEncode Entitlement {entitlementName, expiresAt, extraInfo} = smpEncode (entitlementName, strEncode expiresAt, extraInfo) smpP = do - (name, expBs, extra) <- smpP + (entitlementName, expBs, extraInfo) <- smpP expiresAt <- either fail pure $ strDecode (expBs :: ByteString) - pure Entitlement {entitlementName = name, expiresAt, extraInfo = extra} + pure Entitlement {entitlementName, expiresAt, extraInfo} instance Encoding EntitlementProof where smpEncode EntitlementProof {issuerKeyIdx, proof, entitlement} = @@ -105,7 +106,7 @@ disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} = -- | Issuer side: sign an entitlement for a holder master key. signEntitlement :: BBSSecretKey -> Int -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) signEntitlement sk keyIdx mk ent = - fmap (\sig -> EntitlementCredential keyIdx mk sig ent) <$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) + EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) -- | Holder side: verify the credential received from the issuer. verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool @@ -115,7 +116,7 @@ verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitleme -- | Holder side: generate a proof bound to the presentation header. generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof) generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = - fmap (\p -> EntitlementProof issuerKeyIdx p entitlement) <$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) + EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) -- | Verifier side: verify the proof with the configured key its index points to, -- against the supplied presentation header. Nothing means the key index is not From 8a998a7cf720ec102cdc34325da2be6aca592196 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Thu, 27 Aug 2026 21:30:09 +0100 Subject: [PATCH 12/19] simpler --- src/Simplex/Messaging/Crypto/Entitlement.hs | 33 +++++++++------------ 1 file changed, 14 insertions(+), 19 deletions(-) diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 125ebc057..131016b0c 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -54,21 +54,18 @@ data Entitlement = Entitlement } deriving (Eq, Show) --- | The signing form, held by the entitlement holder; never transmitted. data EntitlementCredential = EntitlementCredential - { issuerKeyIdx :: Int, + { issuerKeyIdx :: Word16, masterKey :: MasterKey, entitlement :: Entitlement, issuerSignature :: BBSSignature } deriving (Eq, Show) --- | The proof form. The presentation header is not part of the proof: the --- verifier supplies it, so a proof cannot claim its own binding. data EntitlementProof = EntitlementProof - { issuerKeyIdx :: Int, + { issuerKeyIdx :: Word16, entitlement :: Entitlement, - proof :: BBSProof + entProof :: BBSProof } deriving (Eq, Show) @@ -81,11 +78,11 @@ instance Encoding Entitlement where pure Entitlement {entitlementName, expiresAt, extraInfo} instance Encoding EntitlementProof where - smpEncode EntitlementProof {issuerKeyIdx, proof, entitlement} = - smpEncode (fromIntegral issuerKeyIdx :: Word16, proof, entitlement) + smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} = + smpEncode (issuerKeyIdx, entProof, entitlement) smpP = do - (idx, proof, entitlement) <- smpP - pure EntitlementProof {issuerKeyIdx = fromIntegral (idx :: Word16), proof, entitlement} + (issuerKeyIdx, entProof, entitlement) <- smpP + pure EntitlementProof {issuerKeyIdx, entProof, entitlement} entitlementBBSHeader :: BBSHeader entitlementBBSHeader = BBSHeader "SimpleX entitlement v1" @@ -104,7 +101,7 @@ disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} = [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] -- | Issuer side: sign an entitlement for a holder master key. -signEntitlement :: BBSSecretKey -> Int -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) +signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) signEntitlement sk keyIdx mk ent = EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) @@ -118,15 +115,13 @@ generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHead generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) --- | Verifier side: verify the proof with the configured key its index points to, --- against the supplied presentation header. Nothing means the key index is not --- among the configured keys. -verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) -verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, proof, entitlement} = +-- | Verifier side: verify the proof with the configured key. +verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) +verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} = forM (M.lookup issuerKeyIdx keys) $ \pk -> - bbsProofVerify pk proof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) + bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) -entitlementIssuerKeys :: Map Int BBSPublicKey +entitlementIssuerKeys :: Map Word16 BBSPublicKey entitlementIssuerKeys = M.fromList [ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"), @@ -139,7 +134,7 @@ entitlementIssuerKeys = (8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd") ] where - key = fromRight (error "bad base64 in entitlement issuer key") . strDecode . B.pack + key = fromRight (error "bad base64 in BBSPublicKey") . strDecode . B.pack $(JQ.deriveJSON defaultJSON ''Entitlement) From af4bed883692c9a35cd3eeef89e7c644e44fca69 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 20:36:09 +0000 Subject: [PATCH 13/19] remove comments --- src/Simplex/Messaging/Crypto/Entitlement.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 131016b0c..acf6f9b35 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -6,11 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | A generic entitlement, proven with a BBS proof over the SHA-256 suite. --- The holder secret (the master key) is the undisclosed message; the name, the --- expiration, and the extra string are disclosed. The protocol and the server --- reference the entitlement, never a badge; chat maps its own badge to an --- entitlement. module Simplex.Messaging.Crypto.Entitlement ( Entitlement (..), EntitlementCredential (..), @@ -46,7 +41,6 @@ newtype MasterKey = MasterKey ByteString deriving newtype (Eq, Show, StrEncoding) deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey) --- | The disclosed content of an entitlement proof. data Entitlement = Entitlement { entitlementName :: Text, expiresAt :: UTCTime, @@ -100,22 +94,18 @@ disclosedMessages :: Entitlement -> [ByteString] disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} = [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] --- | Issuer side: sign an entitlement for a holder master key. signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) signEntitlement sk keyIdx mk ent = EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) --- | Holder side: verify the credential received from the issuer. verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} = bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement) --- | Holder side: generate a proof bound to the presentation header. generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof) generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) --- | Verifier side: verify the proof with the configured key. verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} = forM (M.lookup issuerKeyIdx keys) $ \pk -> From 1ce2df9aa007ddcf5e8b226f2dddebe56baa8b6c Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 27 Aug 2026 21:49:05 +0000 Subject: [PATCH 14/19] add file expiration time to agent event --- plans/2026-08-22-xftp-file-storage-time.md | 9 ++++++++- rfcs/2026-08-22-xftp-file-storage-time.md | 2 +- src/Simplex/FileTransfer/Agent.hs | 8 ++++++-- src/Simplex/FileTransfer/Client.hs | 4 ++-- src/Simplex/FileTransfer/Client/Main.hs | 2 +- src/Simplex/FileTransfer/Protocol.hs | 2 +- src/Simplex/FileTransfer/Types.hs | 7 +++++-- src/Simplex/Messaging/Agent/Client.hs | 6 +++--- src/Simplex/Messaging/Agent/Protocol.hs | 4 ++-- .../Messaging/Agent/Store/AgentStore.hs | 20 +++++++++---------- .../M20260823_snd_files_entitlement.hs | 2 ++ .../M20260823_snd_files_entitlement.hs | 2 ++ tests/AgentTests/SQLiteTests.hs | 3 ++- tests/XFTPAgent.hs | 6 +++++- tests/XFTPServerTests.hs | 2 +- tests/XFTPWebTests.hs | 6 +++++- 16 files changed, 56 insertions(+), 29 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index a2747f154..33ebd40a8 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -112,7 +112,14 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: - in `agentXFTPNewChunk`, read the credential, the storage time, and the digest from the send record - inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof -- discard the returned expiration for now +- `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica` + +Completion: + +- `createXFTPChunk` returns the granted expiry as `Maybe GrantedStorageTime`; `SndFileChunkReplica` and `NewSndChunkReplica` carry `expiresAt :: Maybe GrantedStorageTime` +- persist it in a nullable `replica_expires_at` column on `snd_file_chunk_replicas` (added to the entitlement migration): `createSndFileReplica` stores `epochSeconds`, `getSndFile` reads it back into `GSTExpires` +- on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord` +- `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later) ## simplex-chat diff --git a/rfcs/2026-08-22-xftp-file-storage-time.md b/rfcs/2026-08-22-xftp-file-storage-time.md index ae9f4c4ac..b290d5455 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -13,7 +13,7 @@ The proof discloses the entitlement and includes the issuer key index and the BB ``` entitlement = entName entExpires entExtra entName = shortString ; e.g. "supporter", "legend" -entExpires = shortString ; expiration, encoded as signed +entExpires = shortString ; expiration as a UTCTime ISO8601 string entExtra = shortString ; opaque, interpretation out of scope entitlementProof = issuerKeyIndex bbsProof entitlement diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 43e37b6ed..564eada1b 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 (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime, SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -544,7 +544,7 @@ runXFTPSndWorker c srv Worker {doWork} = do notify c sndFileEntityId $ SFPROG uploaded total when complete $ do (sndDescr, rcvDescrs) <- sndFileToDescrs sf - notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs + notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks) lift . forM_ prefixPath $ removePath <=< toFSFilePath withStore' c $ \db -> updateSndFileComplete db sndFileId where @@ -578,6 +578,10 @@ runXFTPSndWorker c srv Worker {doWork} = do let chunkSize = FileSize $ sndChunkSize ch replicas = [FileChunkReplica {server, replicaId, replicaKey}] pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas} + sndFileExpiresAt :: [SndFileChunk] -> Maybe GrantedStorageTime + sndFileExpiresAt = fmap minimum . mapM chunkExpiresAt + where + chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas) createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient] createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks where diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index fa120cea8..fbd498e57 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -256,10 +256,10 @@ createXFTPChunk :: Maybe BasicAuth -> Maybe Int64 -> Maybe EntitlementProof -> - ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) createXFTPChunk c spKey file rcps auth_ storageTime proof = sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case - (FRSndIds sId rIds _, body) -> noFile body (sId, rIds) + (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs) (r, _) -> throwE $ unexpectedResponse r addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index f8b172b6e..0c934f5ef 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 Nothing Nothing + (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 2005f2aa6..d8225020d 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -202,7 +202,7 @@ data FileInfo = FileInfo deriving (Show) data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} - deriving (Eq, Show) + deriving (Eq, Ord, Show) xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 4816d0d0e..36dbcedae 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -41,6 +41,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word32) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (GrantedStorageTime (..)) import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C @@ -234,7 +235,8 @@ data NewSndChunkReplica = NewSndChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, replicaKey :: C.APrivateAuthKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)] + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)], + expiresAt :: Maybe GrantedStorageTime } deriving (Show) @@ -246,7 +248,8 @@ data SndFileChunkReplica = SndFileChunkReplica rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)], replicaStatus :: SndFileReplicaStatus, delay :: Maybe Int64, - retries :: Int + retries :: Int, + expiresAt :: Maybe GrantedStorageTime } deriving (Show) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 682cfd999..1bfc79a8a 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 Nothing Nothing + (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 @@ -2194,11 +2194,11 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> do + (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> do proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] - pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} + pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt} where mkEntitlementProof sessId sndKey = pure credential diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 78630b9cb..a2db356a6 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -228,7 +228,7 @@ import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word16, Word32) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime) import Simplex.FileTransfer.Transport (XFTPErrorType) import Simplex.FileTransfer.Types (FileErrorType) import Simplex.Messaging.Agent.QueryString @@ -444,7 +444,7 @@ data AEvent (e :: AEntity) where RFERR :: AgentErrorType -> AEvent AERcvFile RFWARN :: AgentErrorType -> AEvent AERcvFile SFPROG :: Int64 -> Int64 -> AEvent AESndFile - SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent AESndFile + SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> Maybe GrantedStorageTime -> AEvent AESndFile SFERR :: AgentErrorType -> AEvent AESndFile SFWARN :: AgentErrorType -> AEvent AESndFile diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 09c574573..d4cfc3b34 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 (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..), SFileParty (..)) import Simplex.FileTransfer.Types import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Protocol @@ -3511,7 +3511,7 @@ getSndFile db sndFileId = runExceptT $ do db [sql| SELECT - r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, + r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at, s.xftp_host, s.xftp_port, s.xftp_key_hash FROM snd_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id @@ -3522,10 +3522,10 @@ getSndFile db sndFileId = runExceptT $ do rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId pure (replica :: SndFileChunkReplica) {rcvIdsKeys} where - toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica - toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica + toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec, host, port, keyHash) = let server = XFTPServer host port keyHash - in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} + in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []} getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] getChunkReplicaRecipients_ db replicaId = @@ -3606,16 +3606,16 @@ createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> I createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO () -createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do +createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys, expiresAt} = do srvId <- createXFTPServer_ db server DB.execute db [sql| INSERT INTO snd_file_chunk_replicas - (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status) - VALUES (?,?,?,?,?,?) + (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status, replica_expires_at) + VALUES (?,?,?,?,?,?,?) |] - (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated) + (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated, epochSeconds <$> expiresAt) rId <- insertedRowId db forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do DB.execute @@ -3688,7 +3688,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do chunkSpec, digest, filePrefixPath, - replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}] + replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = Nothing, rcvIdsKeys = []}] } updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () 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 ea630f28d..b3fb2938e 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 @@ -11,11 +11,13 @@ m20260823_snd_files_entitlement = [r| ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; ALTER TABLE snd_files ADD COLUMN storage_time BIGINT; +ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at BIGINT; |] down_m20260823_snd_files_entitlement :: Text down_m20260823_snd_files_entitlement = [r| +ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at; ALTER TABLE snd_files DROP COLUMN storage_time; ALTER TABLE snd_files DROP COLUMN entitlement_credential; |] 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 e0bc3cde9..48bd1209d 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 @@ -10,11 +10,13 @@ m20260823_snd_files_entitlement = [sql| ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; ALTER TABLE snd_files ADD COLUMN storage_time INTEGER; +ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at INTEGER; |] down_m20260823_snd_files_entitlement :: Query down_m20260823_snd_files_entitlement = [sql| +ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at; ALTER TABLE snd_files DROP COLUMN storage_time; ALTER TABLE snd_files DROP COLUMN entitlement_credential; |] diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 3836332f2..9c58c59eb 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -798,7 +798,8 @@ newSndChunkReplica1 = { server = xftpServer1, replicaId = ChunkReplicaId $ EntityId "abc", replicaKey = testFileReplicaKey, - rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)] + rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)], + expiresAt = Nothing } testGetNextSndChunkToUpload :: DBStore -> Expectation diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index eed1d469d..5c3174dd5 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -33,7 +33,8 @@ import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers) import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) -import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv) +import Simplex.Messaging.Agent.Protocol hiding (SFDONE) +import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Client (pattern NRMInteractive) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) @@ -56,6 +57,9 @@ import Fixtures import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #endif +pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile +pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _ + xftpAgentTests :: SpecWith AFStoreType xftpAgentTests = around_ testBracket diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 4b2aed6a9..5be3b9c53 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -103,7 +103,7 @@ createTestChunk fp = do 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 +createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing Nothing readChunk :: XFTPFileId -> IO ByteString readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ unEntityId sId)) diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index 4e0592222..230151155 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -49,7 +49,8 @@ import Simplex.FileTransfer.Server.Store (STMFileStore) import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpSendFile, xftpTestPort) import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent) import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers) -import Simplex.Messaging.Agent.Protocol (AEvent (..)) +import Simplex.Messaging.Agent.Protocol hiding (SFDONE) +import qualified Simplex.Messaging.Agent.Protocol as A import SMPAgentClient (agentCfg, initAgentServers, testDB) import XFTPCLI (recipientFiles, senderFiles, testBracket) import qualified Simplex.Messaging.Crypto.File as CF @@ -168,6 +169,9 @@ impAddr = "import * as Addr from './dist/protocol/address.js';" jsOut :: String -> String jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));" +pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile +pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _ + xftpWebTests :: IO () -> Spec xftpWebTests dbCleanup = do xftpWebSourceHygieneTests From f064513177c91c42e0d88d7e725d32f43eb3d0e9 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Fri, 28 Aug 2026 10:17:42 +0000 Subject: [PATCH 15/19] add test of upload with entitlement --- plans/2026-08-22-xftp-file-storage-time.md | 9 ++++-- src/Simplex/FileTransfer/Server.hs | 5 +-- src/Simplex/FileTransfer/Server/Env.hs | 4 ++- src/Simplex/FileTransfer/Server/Main.hs | 6 ++-- src/Simplex/Messaging/Agent/Client.hs | 9 +++--- src/Simplex/Messaging/Agent/Env/SQLite.hs | 4 +++ tests/XFTPAgent.hs | 37 +++++++++++++++++++++- tests/XFTPClient.hs | 1 + 8 files changed, 63 insertions(+), 12 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index 33ebd40a8..b7f4759be 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -66,9 +66,9 @@ In `Simplex.FileTransfer.Server`: In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: - make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds -- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend` +- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`; an absent key is skipped (that name gets the default), a present but malformed value fails startup - exit at startup if any name's maximum is below the default file expiration -- read the issuer public keys from the shared constant +- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); `storageMaxSeconds` verifies the proof against it, so the trusted keys never come from the sender ## simplexmq: server store and expiration @@ -110,6 +110,7 @@ Store, in both the SQLite and PostgreSQL agent stores: Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: +- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant); `mkEntitlementProof` looks up `issuerKeyIdx` there to get the issuer public key that proof generation needs - in `agentXFTPNewChunk`, read the credential, the storage time, and the digest from the send record - inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof - `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica` @@ -121,6 +122,10 @@ Completion: - on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord` - `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later) +Testing: + +- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys`, send a file with the credential requesting a number of hours below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default) + ## simplex-chat - remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index f40867160..968398571 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -56,7 +56,7 @@ import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSPresHeader) -import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), entitlementIssuerKeys, verifyEntitlement) +import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -509,10 +509,11 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case storageMaxSeconds _ Nothing = asks $ ttl . fileExpiration . config storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do entCfg <- asks $ fileStorageEntitlements . config + keys <- asks $ entitlementKeys . config defaultMax <- asks $ ttl . fileExpiration . config now <- liftIO getCurrentTime let Entitlement {entitlementName, expiresAt} = ent - liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case + liftIO (verifyEntitlement keys ph proof) >>= \case Just True | addUTCTime nominalDay expiresAt > now -> pure $ fromMaybe defaultMax (M.lookup entitlementName entCfg) _ -> pure defaultMax addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index c42e4050a..8c55f770e 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -41,11 +41,12 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Time.Clock (getCurrentTime) -import Data.Word (Word32) +import Data.Word (Word16, Word32) import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) @@ -95,6 +96,7 @@ data XFTPServerConfig s = XFTPServerConfig fileExpiration :: ExpirationConfig, -- | maximum storage time per entitlement name, seconds fileStorageEntitlements :: Map Text Int64, + entitlementKeys :: Map Word16 BBSPublicKey, -- | timeout to receive file fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index b3c7b08a3..3729e80c7 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -35,6 +35,7 @@ import Simplex.FileTransfer.Server (runXFTPServer) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, AFStoreType (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, readFileStoreType, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase) import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) @@ -292,6 +293,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini }, fileStorageEntitlements = iniEntitlements ini, + entitlementKeys = entitlementIssuerKeys, fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini @@ -443,5 +445,5 @@ iniEntitlements :: Ini -> Map T.Text Int64 iniEntitlements ini = M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")] where - readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini)) - parseMax t = (3600 *) <$> (readMaybe (T.unpack (T.strip t)) :: Maybe Int64) + readEntitlement (name, key) = (name,) . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini) + parseHours key t = maybe (error $ "Error: invalid " <> T.unpack key <> " value: " <> T.unpack t) (3600 *) (readMaybe (T.unpack (T.strip t)) :: Maybe Int64) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 1bfc79a8a..94c5e22f8 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 (..), entitlementIssuerKeys, generateEntitlementProof) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), generateEntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client @@ -2194,15 +2194,16 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest + keys <- asks $ entitlementKeys . config (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> do - proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey + proof <- liftIO $ mkEntitlementProof keys (sessionId $ X.thParams xftp) sndKey X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt} where - mkEntitlementProof sessId sndKey = + mkEntitlementProof keys sessId sndKey = pure credential - $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) entitlementIssuerKeys) + $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys) $>>= \pk -> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest) >>= \case Right p -> pure $ Just p diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index c8a98264f..709a44674 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -67,6 +67,8 @@ import Simplex.Messaging.Agent.Store.Interface (DBOpts) import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..)) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) +import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys) import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) @@ -148,6 +150,7 @@ data AgentConfig = AgentConfig smpCfg :: ProtocolClientConfig SMPVersion, ntfCfg :: ProtocolClientConfig NTFVersion, xftpCfg :: XFTPClientConfig, + entitlementKeys :: Map Word16 BBSPublicKey, reconnectInterval :: RetryInterval, messageRetryInterval :: RetryInterval2, userNetworkInterval :: Int, @@ -226,6 +229,7 @@ defaultAgentConfig = smpCfg = defaultSMPClientConfig, ntfCfg = defaultNTFClientConfig, xftpCfg = defaultXFTPClientConfig, + entitlementKeys = entitlementIssuerKeys, reconnectInterval = defaultReconnectInterval, messageRetryInterval = defaultMessageRetryInterval, userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 5c3174dd5..d1019231f 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -20,23 +21,30 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Int (Int64) import Data.List (find, isSuffixOf) +import qualified Data.Map.Strict as M import Data.Maybe (fromJust) +import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay) +import Data.Time.Clock.System (getSystemTime, systemSeconds) import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3) import SMPClient (xit'') import Simplex.FileTransfer.Client (XFTPClientConfig (..)) import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription) -import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..)) import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..)) import Simplex.FileTransfer.Server.Store (STMFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers) +import qualified Simplex.Messaging.Agent as XA import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg) +import qualified Simplex.Messaging.Agent.Env.SQLite as AEnv import Simplex.Messaging.Agent.Protocol hiding (SFDONE) import qualified Simplex.Messaging.Agent.Protocol as A import Simplex.Messaging.Client (pattern NRMInteractive) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (bbsKeyGen) +import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), signEntitlement) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) @@ -75,6 +83,7 @@ xftpAgentTests = it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect + it "should extend storage time with an entitlement proof and report the granted expiry" $ \_ -> testXFTPAgentEntitlement describe "sending and receiving with version negotiation" $ beforeWith (const (pure ())) testXFTPAgentSendReceiveMatrix it "should resume receiving file after restart" $ \_ -> testXFTPAgentReceiveRestore it "should cleanup rcv tmp path after permanent error" $ \_ -> testXFTPAgentReceiveCleanup @@ -330,6 +339,32 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO () testNoRedundancy (ValidFileDescription FileDescription {chunks}) = all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True +testXFTPAgentEntitlement :: HasCallStack => IO () +testXFTPAgentEntitlement = do + Right (issuerPk, issuerSk) <- bbsKeyGen + now <- getCurrentTime + let ent = Entitlement {entitlementName = "supporter", expiresAt = addUTCTime (30 * nominalDay) now, extraInfo = ""} + keys = M.fromList [(1, issuerPk)] + Right credential <- signEntitlement issuerSk 1 (MasterKey "0123456789abcdef0123456789abcdef") ent + let srvCfg = testXFTPServerConfig {entitlementKeys = keys, fileStorageEntitlements = M.fromList [("supporter", 168 * 3600)]} + withXFTPServerCfg srvCfg $ \_ -> do + filePath <- createRandomFile_ (kb 128 :: Integer) "testfile" + withAgent 1 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB $ \sndr -> runRight_ $ do + xftpStartWorkers sndr (Just senderFiles) + nowSec <- liftIO $ systemSeconds <$> getSystemTime + _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just credential) (Just 100) + gExpires <- waitSndDone sndr + liftIO $ case gExpires of + Just (GSTExpires t) -> do + t `shouldSatisfy` (>= nowSec + 100 * 3600) + t `shouldSatisfy` (< nowSec + 100 * 3600 + 7200) + Nothing -> expectationFailure "expected granted storage time in SFDONE" + where + waitSndDone sndr = + sfGet sndr >>= \case + ("", _, A.SFDONE _ _ g) -> pure g + _ -> waitSndDone sndr + testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceive rcp rfd = testReceiveCF rcp rfd Nothing diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index d694cf271..2b28348fb 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -186,6 +186,7 @@ testXFTPServerConfig = controlPortUserAuth = Nothing, fileExpiration = defaultFileExpiration, fileStorageEntitlements = mempty, + entitlementKeys = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, xftpCredentials = From 173916bca30115601622d519343f0f94d40e6a44 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Fri, 28 Aug 2026 12:43:22 +0100 Subject: [PATCH 16/19] update schema --- .../Agent/Store/Postgres/Migrations/agent_postgres_schema.sql | 4 +++- .../Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql index 000a4fd51..465c569a5 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql @@ -741,7 +741,9 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_files ( src_file_nonce bytea, failed smallint DEFAULT 0, redirect_size bigint, - redirect_digest bytea + redirect_digest bytea, + entitlement_credential text, + storage_time bigint ); diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index b00593601..a24249e83 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -352,7 +352,9 @@ CREATE TABLE snd_files( src_file_nonce BLOB, failed INTEGER DEFAULT 0, redirect_size INTEGER, - redirect_digest BLOB + redirect_digest BLOB, + entitlement_credential TEXT, + storage_time INTEGER ) STRICT; CREATE TABLE snd_file_chunks( snd_file_chunk_id INTEGER PRIMARY KEY, From 6541745fcae12880d0a60a2f82bc45d2ecce571a Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Fri, 28 Aug 2026 11:43:55 +0000 Subject: [PATCH 17/19] fix header and test --- plans/2026-08-22-xftp-file-storage-time.md | 2 +- src/Simplex/Messaging/Crypto/Entitlement.hs | 3 +- tests/CoreTests/XFTPStoreTests.hs | 32 ++++++++++----------- 3 files changed, 19 insertions(+), 18 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index b7f4759be..ba1e0b0a4 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -34,7 +34,7 @@ data EntitlementProof = EntitlementProof Functions and constants: - the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed -- the BBS header string `"SimpleX entitlement v1"`, the message count, and the disclosed indexes +- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes - `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` - `verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it) - the issuer public keys constant `Map Int BBSPublicKey` diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index acf6f9b35..049954b10 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Crypto.Entitlement EntitlementCredential (..), EntitlementProof (..), MasterKey (..), + entitlementBBSHeader, entitlementIssuerKeys, signEntitlement, verifyCredential, @@ -79,7 +80,7 @@ instance Encoding EntitlementProof where pure EntitlementProof {issuerKeyIdx, entProof, entitlement} entitlementBBSHeader :: BBSHeader -entitlementBBSHeader = BBSHeader "SimpleX entitlement v1" +entitlementBBSHeader = BBSHeader "SimpleX badges v1" entitlementMessageCount :: Int entitlementMessageCount = 4 diff --git a/tests/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index 20c0e77fc..87afb8e68 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -75,7 +75,7 @@ testAddGetFileSender = withPgStore $ \st -> do g <- C.newRandom (sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sk - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () result <- getFile st SFSender testSenderId case result of Right (FileRec {senderId, fileInfo = fi, createdAt}, key) -> do @@ -92,7 +92,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () result <- getFile st SFRecipient testRecipientId case result of @@ -106,8 +106,8 @@ testDuplicateFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Left DUPLICATE_ + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_ testGetNonexistent :: Expectation testGetNonexistent = withPgStore $ \st -> do @@ -119,7 +119,7 @@ testSetFilePath = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () setFilePath st testSenderId "/tmp/test_file" `shouldReturn` Right () -- Second setFilePath should fail (file_path IS NULL guard) setFilePath st testSenderId "/tmp/other_file" `shouldReturn` Left AUTH @@ -135,7 +135,7 @@ testDuplicateRecipient = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_ @@ -145,7 +145,7 @@ testDeleteFileCascade = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () deleteFile st testSenderId `shouldReturn` Right () -- File and recipient should both be gone @@ -157,7 +157,7 @@ testBlockFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () let blockInfo = BlockingInfo {reason = BRContent, notice = Nothing} blockFile st testSenderId blockInfo False `shouldReturn` Right () result <- getFile st SFSender testSenderId @@ -171,7 +171,7 @@ testAckFile = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () ackFile st testRecipientId `shouldReturn` Right () -- Recipient gone, but file still exists @@ -189,11 +189,11 @@ testExpiredFiles = withPgStore $ \st -> do oldTime = RoundedSystemTime 100000 newTime = RoundedSystemTime 999999999 -- Add old and new files - addFile st (EntityId "old_file________") fileInfo oldTime EntityActive `shouldReturn` Right () + addFile st (EntityId "old_file________") fileInfo oldTime Nothing EntityActive `shouldReturn` Right () void $ setFilePath st (EntityId "old_file________") "/tmp/old" - addFile st (EntityId "new_file________") fileInfo newTime EntityActive `shouldReturn` Right () + addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right () -- Query expired with cutoff that only catches old file - expired <- expiredFiles st 500000 100 + expired <- expiredFiles st 500000 500000 100 length expired `shouldBe` 1 case expired of [(sId, path, sz)] -> do @@ -222,8 +222,8 @@ testStorageAndCountForStore st = do fileInfoB = fileInfoA {size = 64000} fileA = EntityId "file_a__________" fileB = EntityId "file_b__________" - addFile st fileA fileInfoA testCreatedAt EntityActive `shouldReturn` Right () - addFile st fileB fileInfoB testCreatedAt EntityActive `shouldReturn` Right () + addFile st fileA fileInfoA testCreatedAt Nothing EntityActive `shouldReturn` Right () + addFile st fileB fileInfoB testCreatedAt Nothing EntityActive `shouldReturn` Right () getFileCount st `shouldReturn` 2 getUsedStorage st `shouldReturn` 0 setFilePath st fileA "/tmp/file_a" `shouldReturn` Right () @@ -248,11 +248,11 @@ testMigrationRoundTrip = do sId1 = EntityId "migration_file_1" sId2 = EntityId "migration_file_2" rId1 = EntityId "migration_rcp_1_" - addFile stmStore sId1 fileInfo1 testCreatedAt EntityActive `shouldReturn` Right () + addFile stmStore sId1 fileInfo1 testCreatedAt Nothing EntityActive `shouldReturn` Right () void $ setFilePath stmStore sId1 "/tmp/file1" addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right () let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing} - addFile stmStore sId2 fileInfo2 testCreatedAt (EntityBlocked testBlockInfo) `shouldReturn` Right () + addFile stmStore sId2 fileInfo2 testCreatedAt Nothing (EntityBlocked testBlockInfo) `shouldReturn` Right () -- 2. Write to StoreLog sl <- openWriteStoreLog False storeLogPath writeFileStore sl stmStore From 370c4e6c19a187c9381efedce656b17079a7f53a Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 30 Aug 2026 16:30:57 +0000 Subject: [PATCH 18/19] fix store log encoding, add xftp store log tests --- src/Simplex/FileTransfer/Server/StoreLog.hs | 6 +- tests/CoreTests/StoreLogTests.hs | 76 +++++++++++++++++++++ tests/Test.hs | 1 + 3 files changed, 80 insertions(+), 3 deletions(-) diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 656d31904..c6f792943 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -20,7 +20,7 @@ module Simplex.FileTransfer.Server.StoreLog ) where -import Control.Applicative ((<|>)) +import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A @@ -52,7 +52,7 @@ data FileStoreLogRecord instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> expE expiresAt + AddFile sId file createdAt expiresAt status -> B.concat [strEncode (Str "FNEW", sId, file, createdAt), expE expiresAt, " ", strEncode status] PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) @@ -74,8 +74,8 @@ instance StrEncoding FileStoreLogRecord where sId <- strP_ file <- strP_ createdAt <- strP + expiresAt <- optional _strP status <- _strP <|> pure EntityActive - expiresAt <- (A.space *> (Just <$> strP)) <|> pure Nothing pure $ AddFile sId file createdAt expiresAt status logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 01966ba05..1b59430a3 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -20,9 +20,13 @@ import qualified Data.Map.Strict as M import qualified Data.X509 as X import qualified Data.X509.Validation as XV import SMPClient +import Simplex.FileTransfer.Protocol (FileInfo (..)) +import Simplex.FileTransfer.Server.Store (FileRec (..), FileRecipient (..), FileStoreClass (..), RoundedFileTime, STMFileStore (..)) +import Simplex.FileTransfer.Server.StoreLog (FileStoreLogRecord (..), readWriteFileStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol +import Simplex.Messaging.Protocol.Types (ClientNotice (..)) import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.Types @@ -191,3 +195,75 @@ testSMPStoreLog testSuite tests = compacted' `shouldBe` compacted storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec) storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec)) + +type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) + +type XFTPStoreLogTestCase = StoreLogTestCase FileStoreLogRecord (M.Map SenderId FileRecState) + +deriving instance Eq FileInfo + +deriving instance Eq FileRecipient + +deriving instance Eq FileStoreLogRecord + +testFileStoreLogFile :: FilePath +testFileStoreLogFile = "tests/tmp/xftp-server-store.log" + +fileStoreLogTests :: Spec +fileStoreLogTests = do + g <- runIO C.newRandom + (sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g + sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g + let file = FileInfo {sndKey, size = 16384, digest = "12345678"} + createdAt = RoundedSystemTime 1600000000 + expiresAt = RoundedSystemTime 1600172800 + blocked = BlockingInfo {reason = BRSpam, notice = Nothing} + blockedWithNotice = BlockingInfo {reason = BRContent, notice = Just ClientNotice {ttl = Just 86400}} + testXFTPStoreLog + "XFTP server store log" + [ SLTC + { name = "create file", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive], + compacted = [AddFile sId file createdAt (Just expiresAt) EntityActive], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityActive))] + }, + SLTC + { name = "create file without expiration", + saved = [AddFile sId file createdAt Nothing EntityActive], + compacted = [AddFile sId file createdAt Nothing EntityActive], + state = M.fromList [(sId, (file, createdAt, Nothing, EntityActive))] + }, + SLTC + { name = "create and block file", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blocked], + compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blocked)], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blocked))] + }, + SLTC + { name = "create and block file with notice", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice], + compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))] + } + ] + +testXFTPStoreLog :: String -> [XFTPStoreLogTestCase] -> Spec +testXFTPStoreLog testSuite tests = + describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do + l <- openWriteStoreLog False testFileStoreLogFile + mapM_ (writeStoreLogRecord l) saved + closeStoreLog l + replicateM_ 3 $ testReadWrite t + where + testReadWrite SLTC {compacted, state} = do + st <- newFileStore () :: IO STMFileStore + l <- readWriteFileStore testFileStoreLogFile st + storeState st `shouldReturn` state + closeStoreLog l + ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile + compacted' `shouldBe` compacted + storeState :: STMFileStore -> IO (M.Map SenderId FileRecState) + storeState st = readTVarIO (files st) >>= mapM fileState + fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do + status <- readTVarIO fileStatus + pure (fileInfo, createdAt, expiresAt, status) diff --git a/tests/Test.hs b/tests/Test.hs index c2968828b..77229a28f 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -97,6 +97,7 @@ main = do #else describe "Store log tests" storeLogTests #endif + describe "XFTP store log tests" fileStoreLogTests describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests describe "Names resolver tests" smpNamesTests From d37bf94dc6449699dd5f4c7c9f6e7ad8e1345703 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Sun, 30 Aug 2026 18:37:52 +0000 Subject: [PATCH 19/19] send entitlement proof in handshake --- plans/2026-08-22-xftp-file-storage-time.md | 60 ++++++++++++----- rfcs/2026-08-22-xftp-file-storage-time.md | 34 +++++++--- src/Simplex/FileTransfer/Agent.hs | 18 ++--- src/Simplex/FileTransfer/Client.hs | 21 +++--- src/Simplex/FileTransfer/Client/Agent.hs | 2 +- src/Simplex/FileTransfer/Client/Main.hs | 2 +- src/Simplex/FileTransfer/Protocol.hs | 20 ++---- src/Simplex/FileTransfer/Server.hs | 66 +++++++++++-------- src/Simplex/FileTransfer/Server/Env.hs | 9 +-- src/Simplex/FileTransfer/Server/Main.hs | 5 +- src/Simplex/FileTransfer/Transport.hs | 14 ++-- src/Simplex/FileTransfer/Types.hs | 1 - src/Simplex/Messaging/Agent.hs | 12 +++- src/Simplex/Messaging/Agent/Client.hs | 56 ++++++++++------ src/Simplex/Messaging/Agent/Env/SQLite.hs | 3 +- .../Messaging/Agent/Store/AgentStore.hs | 16 ++--- .../M20260823_snd_files_entitlement.hs | 2 - .../Migrations/agent_postgres_schema.sql | 1 - .../M20260823_snd_files_entitlement.hs | 2 - .../Store/SQLite/Migrations/agent_schema.sql | 3 +- .../Messaging/Notifications/Transport.hs | 2 +- src/Simplex/Messaging/Server.hs | 2 +- src/Simplex/Messaging/Transport.hs | 11 +++- tests/AgentTests/SQLiteTests.hs | 6 +- tests/AgentTests/ServerChoice.hs | 1 + tests/SMPAgentClient.hs | 1 + tests/XFTPAgent.hs | 8 ++- tests/XFTPClient.hs | 4 +- tests/XFTPServerTests.hs | 8 +-- 29 files changed, 238 insertions(+), 152 deletions(-) diff --git a/plans/2026-08-22-xftp-file-storage-time.md b/plans/2026-08-22-xftp-file-storage-time.md index ba1e0b0a4..b3deadb90 100644 --- a/plans/2026-08-22-xftp-file-storage-time.md +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -44,6 +44,8 @@ Functions and constants: In `Simplex.FileTransfer.Transport`: - add the next `VersionXFTP` and set `currentXFTPVersion` to 4 +- add `entitlementProof :: Maybe EntitlementProof` to `XFTPClientHandshake`, encoded before the `Tail` and only from this version +- the presentation header is the session id alone In `Simplex.FileTransfer.Protocol`: @@ -53,13 +55,8 @@ In `Simplex.FileTransfer.Protocol`: data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} ``` -- add the storage time (`Maybe Int64`: `Nothing` requests the server maximum, `Just` a number of hours) and `Maybe EntitlementProof` fields to `FNEW` +- add the storage time (`Maybe Int64`: `Nothing` requests the server maximum, `Just` a number of hours) to `FNEW` - add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version) -- build the presentation header for FNEW - -In `Simplex.FileTransfer.Server`: - -- pass `sessionId` from `thParams` into `processXFTPRequest` ## simplexmq: server configuration @@ -68,7 +65,16 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`: - make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds - read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`; an absent key is skipped (that name gets the default), a present but malformed value fails startup - exit at startup if any name's maximum is below the default file expiration -- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); `storageMaxSeconds` verifies the proof against it, so the trusted keys never come from the sender +- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); the handshake verifies the proof against it, so the trusted keys never come from the sender + +## simplexmq: server session + +In `Simplex.FileTransfer.Server`: + +- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name +- verify only when the answer can change: the name is configured with a maximum above the default, and the entitlement expired less than 24 hours ago. A proof that fails these checks or fails to verify is logged, and the session gets the default maximum +- `HandshakeAccepted` holds the resolved maximum for the session, and `processXFTPRequest` takes it from there, so no proof is verified while a command is processed +- `createFile` caps the requested storage time by the session maximum ## simplexmq: server store and expiration @@ -98,21 +104,31 @@ Store log, in `Simplex.FileTransfer.Server.StoreLog`: ## simplexmq: agent +The credential belongs to the user, so the agent holds it the way it holds the user's servers: in memory, supplied when the agent is created and replaced through an API. It is not stored by the agent. + +Per-user state in `Simplex.Messaging.Agent.Env.SQLite` and `Simplex.Messaging.Agent.Client`: + +- add `entitlements :: Map UserId EntitlementCredential` to `InitialAgentServers`, beside the servers +- add `userEntitlements :: TMap UserId EntitlementCredential` to `AgentClient`, filled from it by `newAgentClient` +- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant), for the issuer key that proof generation needs + Public API in `Simplex.Messaging.Agent`: -- add `Maybe EntitlementCredential` and storage time (`Maybe Int64` hours) parameters to `xftpSendFile` +- add storage time (`Maybe Int64` hours) to `xftpSendFile` +- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and closes that user's XFTP clients, so the next upload presents the new credential Store, in both the SQLite and PostgreSQL agent stores: -- add a nullable entitlement credential column (JSON text) and a nullable storage time column (integer hours; NULL means the server maximum) to `snd_files` +- add 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 +- in `createSndFile`, store the storage time Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: -- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant); `mkEntitlementProof` looks up `issuerKeyIdx` there to get the issuer public key that proof generation needs -- in `agentXFTPNewChunk`, read the credential, the storage time, and the digest from the send record -- inside `withClient`, where `sessionId` is available, build the presentation header `sessionId <> sndKey <> digest`, generate the proof, and send FNEW with the storage time and the proof +- `getXFTPClient` takes a proof for the session as a parameter, `SessionId -> IO (Maybe EntitlementProof)`, beside the callback it already takes for a closed client. The client config holds no credential and no keys +- `getXFTPServerClient` passes a function that reads the user's credential, looks the issuer key up, and generates the proof over the session id. A missing credential or a failure to generate gives `Nothing`, with the failure logged +- `xftpClientHandshakeV1` calls it with the session id from the connection, and sends the result in the handshake +- `agentXFTPNewChunk` reads the storage time from the send record and sends FNEW with it - `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica` Completion: @@ -124,21 +140,29 @@ Completion: Testing: -- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys`, send a file with the credential requesting a number of hours below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default) +- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys` and the credential for the user, send a file requesting a number of hours above the default and below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default) +- the same upload without the credential is capped at the default maximum +- store log round trip in `tests/CoreTests/StoreLogTests.hs`, in the shape of the SMP store log test: a file record survives a write, a read into the store, and compaction, including a file blocked with a notice, where the record has a field after the blocking info ## simplex-chat - remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI - map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent -- pass the user's credential and `FSMaxTime` to `xftpSendFile` +- pass the user's credential to the agent when it is created, and through `setUserEntitlement` when the badge changes, in the same places that pass and update the user's servers +- pass the storage time to `xftpSendFile` - retain the `maxXFTPFileSize` size limit - reuse `verifyEntitlement` for peer-badge verification - import the issuer public keys from the shared simplexmq constant +## State + +Steps 2 to 5 are implemented in simplexmq. Step 1 and step 6 belong to the chat branch that carries badges. + ## Order 1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges. -2. Add the new XFTP version, the FNEW protocol change (storage time + proof), and the response. +2. Add the new XFTP version, the FNEW storage time, 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. +4. Move the proof to the handshake: the handshake field, the session state on the server, and the proof for the session on the client. +5. Hold the credential per user in the agent, and add the API to replace it. +6. 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 b290d5455..7ed6bdf49 100644 --- a/rfcs/2026-08-22-xftp-file-storage-time.md +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -2,7 +2,9 @@ ## Summary -The server stores a storage time for each file. The sender sets it in the FNEW command. The sender may present a proof of an entitlement to raise the maximum storage time the server allows. Each proof is bound to the uploaded chunk and to the TLS session, so it cannot be reused for another chunk or another session. +The server stores a storage time for each file. The sender sets it in the FNEW command. The client may present a proof of an entitlement in the handshake to raise the maximum storage time the server allows. The proof is bound to the TLS session, so it cannot be reused for another session. + +An entitlement belongs to the user, not to a file: the client presents it once per connection, and the server applies it to everything the client does in that session. The server can also vary other limits, such as throttling, by the entitlement. ## Entitlement @@ -21,7 +23,7 @@ issuerKeyIndex = 2*2 OCTET ; Word16, network byte order bbsProof = largeString ; BBS proof bytes ``` -The presentation header that the BBS proof is generated over is not transmitted; the server reconstructs it from the command context (see [Binding](#binding)), which is what binds the proof. +The presentation header that the BBS proof is generated over is not transmitted; the server takes it from the session (see [Binding](#binding)), which is what binds the proof. ## Storage time @@ -32,16 +34,28 @@ storageHours = 8*8 OCTET ; Int64, network byte order The storage time is an optional number of hours. Absent (`%s"0"`) requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value (`%s"1"` with hours) requests a specific number of hours. -## Commands, new XFTP version +## Handshake, new XFTP version -The new protocol version extends FNEW. +The client handshake carries the entitlement proof. ``` -fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime optEntitlementProof +clientHandshake = xftpVersion keyHash optEntitlementProof optEntitlementProof = %s"0" / (%s"1" entitlementProof) ``` -`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode neither `fileStorageTime` nor the proof, and the server applies the default storage time. +`xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof. + +The server verifies the proof once, when it accepts the handshake, and keeps the resulting maximum storage time for the session. A proof that fails to verify, names an entitlement the server does not configure, or names one whose expiration passed more than 24 hours ago, is logged and ignored, and the session gets the default maximum. The client learns nothing about which entitlements the server accepts. + +## Commands + +The new protocol version extends FNEW with the storage time. + +``` +fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime +``` + +`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode no `fileStorageTime`, and the server applies the default storage time. ## Responses @@ -59,13 +73,15 @@ expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant) ## 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. +The presentation header binds the proof to the TLS session, so a proof presented on any other session fails to verify. ``` -presHeader = sessionId sndKey digest +presHeader = sessionId ``` -The chunk is identified by the sender key and the digest, which the server verifies for every command on the file. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`. +`sessionId` is the TLS session identifier, the TLS unique channel binding. Both sides take it from the connection: the client has it once TLS is established, and the client checks that the identifier the server sends in its handshake matches. + +Binding to the session is what stops a proof being replayed by another client. A proof is not bound to a file, because the entitlement belongs to the user and authorises everything the client does in that session. ## Maximum storage time diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 564eada1b..c5a92f58e 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -351,8 +351,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m () notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) -xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AM SndFileId -xftpSendFile' c userId file numRecipients credential storageTime = do +xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Int64 -> AM SndFileId +xftpSendFile' c userId file numRecipients storageTime = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath @@ -360,7 +360,7 @@ xftpSendFile' c userId file numRecipients credential storageTime = do key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing credential storageTime + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageTime lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -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 Nothing + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -406,7 +406,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do prepareFile _ SndFile {prefixPath = Nothing} = throwE $ INTERNAL "no prefix path" prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do - SndFile {numRecipients, chunks, entitlementCredential, storageTime} <- + SndFile {numRecipients, chunks, storageTime} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath @@ -425,7 +425,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - srvs <- forM pendingChunks $ createChunk numRecipients' entitlementCredential storageTime + srvs <- forM pendingChunks $ createChunk numRecipients' storageTime let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -455,8 +455,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of [] -> Left ch SndFileChunkReplica {server} : _ -> Right server - createChunk :: Int -> Maybe EntitlementCredential -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) - createChunk numRecipients' credential storageTime ch = do + createChunk :: Int -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk numRecipients' storageTime ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica @@ -483,7 +483,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId when deleted $ throwE $ FILE NO_FILE withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do - replica <- agentXFTPNewChunk c ch numRecipients' srvAuth credential storageTime + replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageTime pure (replica, srvAuth) sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index fbd498e57..b03881844 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -36,6 +36,7 @@ import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad import Control.Monad.Except +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) @@ -85,7 +86,7 @@ import Simplex.Messaging.Protocol SenderId, pattern NoEntity, ) -import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) +import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), SessionId, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client @@ -127,8 +128,8 @@ defaultXFTPClientConfig = clientALPN = Just alpnSupportedXFTPhandshakes } -getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) -getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do +getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (SessionId -> IO (Maybe EntitlementProof)) -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) +getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs mkEntitlementProof disconnected = runExceptT $ do let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession ProtocolServer _ host port keyHash = srv useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN @@ -147,19 +148,20 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, thParams@THandleParams {thVersion} <- case sessionALPN of Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 -> - xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0 + xftpClientHandshakeV1 serverVRange keyHash http2Client mkEntitlementProof thParams0 _ -> pure thParams0 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c pure c -xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient) -xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do +xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> (SessionId -> IO (Maybe EntitlementProof)) -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient) +xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} mkEntitlementProof thParams0 = do shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake (vr, sk) <- processServerHandshake shs let v = maxVersion vr - sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash} + ep <- if v >= fileStorageTimeXFTPVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing + sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof = ep} let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing} pure thParams0 {thAuth, thVersion = v, thServerVRange = vr} where @@ -255,10 +257,9 @@ createXFTPChunk :: NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> - Maybe EntitlementProof -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) -createXFTPChunk c spKey file rcps auth_ storageTime proof = - sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case +createXFTPChunk c spKey file rcps auth_ storageTime = + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime) Nothing >>= \case (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs) (r, _) -> throwE $ unexpectedResponse r diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 81e0a7597..d5faea92f 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -81,7 +81,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do connectClient = ExceptT $ first (XFTPClientAgentError srv) - <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt clientDisconnected + <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt (\_ -> pure Nothing) clientDisconnected clientDisconnected :: XFTPClient -> IO () clientDisconnected _ = do diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 0c934f5ef..bd5ec74b2 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 Nothing Nothing + (sndId, rIds, _) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth 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 d8225020d..84a256f83 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -23,7 +23,6 @@ module Simplex.FileTransfer.Protocol FileCmd (..), FileInfo (..), GrantedStorageTime (..), - xftpNewProofHeader, XFTPFileId, FileResponse (..), xftpBlockSize, @@ -49,8 +48,6 @@ import Data.Word (Word32) import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub) import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..)) -import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers @@ -82,7 +79,7 @@ import Simplex.Messaging.Protocol tEncodeBatch1, tParse, ) -import Simplex.Messaging.Transport (SessionId, THandleParams (..), TransportError (..), TransportPeer (..)) +import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Util ((<$?>)) xftpBlockSize :: Int @@ -180,7 +177,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where {-# INLINE protocolError #-} data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> Maybe EntitlementProof -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> FileCommand FSender FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender @@ -204,9 +201,6 @@ data FileInfo = FileInfo data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} deriving (Eq, Ord, Show) -xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader -xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest - instance Encoding GrantedStorageTime where smpEncode = \case GSTExpires t -> smpEncode ('T', t) @@ -220,8 +214,8 @@ type XFTPFileId = EntityId instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p encodeProtocol v = \case - FNEW file rKeys auth_ st ep - | v >= fileStorageTimeXFTPVersion -> fnew <> e (st, ep) + FNEW file rKeys auth_ st + | v >= fileStorageTimeXFTPVersion -> fnew <> e st | otherwise -> fnew where fnew = e (FNEW_, ' ', file, rKeys, auth_) @@ -262,10 +256,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where FCT SFSender tag -> FileCmd SFSender <$> case tag of FNEW_ - | v >= fileStorageTimeXFTPVersion -> fnewP smpP smpP - | otherwise -> fnewP (pure Nothing) (pure Nothing) + | v >= fileStorageTimeXFTPVersion -> fnewP smpP + | otherwise -> fnewP (pure Nothing) where - fnewP stP epP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP <*> epP + fnewP stP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 968398571..8b2d38c1c 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -36,6 +36,7 @@ import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Clock (UTCTime (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay) +import Data.Time.Clock.System (systemSeconds, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) import qualified Data.X509 as X @@ -55,7 +56,7 @@ import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.BBS (BBSPresHeader) +import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..)) import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding @@ -69,7 +70,7 @@ import Simplex.Messaging.Server.Stats import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS) +import Simplex.Messaging.Transport (CertChainPubKey (..), EntitlementConfig (..), SessionEntitlement (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) @@ -215,12 +216,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira processClientHandshake pk = do unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE body <- liftHS $ C.unPad bodyHead - XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body + XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body kh <- asks serverIdentity unless (keyHash == kh) $ throwE HANDSHAKE case compatibleVRange' xftpServerVRange v of Just (Compatible vr) -> do - let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing} + ent <- lift $ verifiedEntitlement entitlementProof + let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing} thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions #ifdef slow_servers @@ -229,6 +231,19 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS) pure Nothing Nothing -> throwE HANDSHAKE + verifiedEntitlement :: Maybe EntitlementProof -> M s (Maybe SessionEntitlement) + verifiedEntitlement ep = + pure ep $>>= \proof@EntitlementProof {entitlement = Entitlement {entitlementName, expiresAt = expiresAtTs}} -> do + entCfg <- asks $ M.lookup entitlementName . fileStorageEntitlements . config + now <- liftIO getSystemSeconds + let expiresAt = RoundedSystemTime $ systemSeconds $ utcToSystemTime expiresAtTs + case entCfg of + Just cfg | entitlementValid now expiresAt -> do + keys <- asks $ entitlementKeys . config + liftIO (verifyEntitlement keys (BBSPresHeader sessionId) proof) >>= \case + Just True -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg} + r -> Nothing <$ logError ("entitlement not verified: " <> tshow r) + _ -> pure Nothing sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer)) sendError err = do runExceptT (encodeXftp err) >>= \case @@ -400,9 +415,10 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea | otherwise = case xftpDecodeTServer thParams bodyHead of Right (Right t@(_, _, (corrId, fId, _))) -> do - let THandleParams {thAuth, sessionId} = thParams + let THandleParams {thAuth} = thParams + ent = peerEntitlement =<< thAuth verifyXFTPTransmission thAuth t >>= \case - VRVerified req -> uncurry send =<< processXFTPRequest sessionId body req + VRVerified req -> uncurry send =<< processXFTPRequest ent body req VRFailed e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) @@ -442,7 +458,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = case cmd of - FileCmd SFSender (FNEW file rcps auth' st ep) -> pure $ XFTPReqNew file rcps auth' st ep `verifyWith` sndKey file + FileCmd SFSender (FNEW file rcps auth' st) -> pure $ XFTPReqNew file rcps auth' st `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -463,9 +479,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH -processXFTPRequest :: forall s. FileStoreClass s => SessionId -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) -processXFTPRequest sessionId HTTP2Body {bodyPart} = \case - XFTPReqNew file rks auth storageTime ep -> noFile =<< ifM allowNew (createFile file rks storageTime ep) (pure $ FRErr AUTH) +processXFTPRequest :: forall s. FileStoreClass s => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) +processXFTPRequest ent HTTP2Body {bodyPart} = \case + XFTPReqNew file rks auth storageTime -> noFile =<< ifM allowNew (createFile file rks storageTime) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -482,17 +498,17 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> Maybe EntitlementProof -> M s FileResponse - createFile file@FileInfo {sndKey, digest} rks storageTime ep = do + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> M s FileResponse + createFile file rks storageTime = do st <- asks fileStore r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE ts <- liftIO getFileTime - now <- liftIO $ roundedSeconds <$> getSystemSeconds - maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep - let secs = maybe maxSeconds (\hours -> min (hours * 3600) maxSeconds) storageTime - fileExpiresAt = RoundedSystemTime $ ((now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision + now <- liftIO getSystemSeconds + maxSeconds <- lift $ storageMaxSeconds now + let secs = maybe maxSeconds (min maxSeconds . (* 3600)) storageTime + fileExpiresAt = RoundedSystemTime $ ((roundedSeconds now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision -- TODO validate body empty sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt) rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks @@ -505,17 +521,12 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case let rIds = L.map (\(FileRecipient rId _) -> rId) rcps pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt))) pure $ either FRErr id r - storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s Int64 - storageMaxSeconds _ Nothing = asks $ ttl . fileExpiration . config - storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do - entCfg <- asks $ fileStorageEntitlements . config - keys <- asks $ entitlementKeys . config + storageMaxSeconds :: SystemSeconds -> M s Int64 + storageMaxSeconds now = do defaultMax <- asks $ ttl . fileExpiration . config - now <- liftIO getCurrentTime - let Entitlement {entitlementName, expiresAt} = ent - liftIO (verifyEntitlement keys ph proof) >>= \case - Just True | addUTCTime nominalDay expiresAt > now -> pure $ fromMaybe defaultMax (M.lookup entitlementName entCfg) - _ -> pure defaultMax + pure $ case ent of + Just SessionEntitlement {expiresAt, entConfig} | entitlementValid now expiresAt -> max (storageTime entConfig) defaultMax + _ -> defaultMax addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) addFileRetry st file n ts expiresAt = retryAdd n $ \sId -> runExceptT $ do @@ -654,6 +665,9 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo) +entitlementValid :: SystemSeconds -> SystemSeconds -> Bool +entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now + getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 8c55f770e..ff23c8402 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -69,6 +69,7 @@ import Simplex.FileTransfer.Transport (VersionRangeXFTP) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential) import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) @@ -94,8 +95,8 @@ data XFTPServerConfig s = XFTPServerConfig controlPortAdminAuth :: Maybe BasicAuth, -- | time after which the files can be removed and check interval, seconds fileExpiration :: ExpirationConfig, - -- | maximum storage time per entitlement name, seconds - fileStorageEntitlements :: Map Text Int64, + -- | what each entitlement name grants + fileStorageEntitlements :: Map Text EntitlementConfig, entitlementKeys :: Map Word16 BBSPublicKey, -- | timeout to receive file fileTimeout :: Int, @@ -181,7 +182,7 @@ defaultFileExpiration = newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do let defaultMax = ttl fileExpiration - unless (all (>= defaultMax) (M.elems fileStorageEntitlements)) $ do + unless (all ((>= defaultMax) . storageTime) (M.elems fileStorageEntitlements)) $ do logError "STORE: entitlement storage time is below the default file expiration" exitFailure random <- C.newRandom @@ -208,7 +209,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) (Maybe Int64) (Maybe EntitlementProof) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Int64) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 3729e80c7..51d692dd5 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -44,6 +44,7 @@ import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Information (ServerPublicInfo (..)) import Simplex.Messaging.Server.Main (serverPublicInfo, printSourceCode) import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..)) +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig) @@ -441,9 +442,9 @@ cliCommandP cfgPath logPath iniFile = <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file")) ) -iniEntitlements :: Ini -> Map T.Text Int64 +iniEntitlements :: Ini -> Map T.Text EntitlementConfig iniEntitlements ini = M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")] where - readEntitlement (name, key) = (name,) . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini) + readEntitlement (name, key) = (name,) . EntitlementConfig . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini) parseHours key t = maybe (error $ "Error: invalid " <> T.unpack key <> " value: " <> T.unpack t) (3600 *) (readMaybe (T.unpack (T.strip t)) :: Maybe Int64) diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 24fa3e13c..9742430f3 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -37,7 +37,7 @@ module Simplex.FileTransfer.Transport ) where -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad @@ -57,6 +57,7 @@ import Data.Word (Word16, Word32) import Network.HTTP2.Client (HTTP2Error) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers @@ -135,7 +136,9 @@ data XFTPClientHandshake = XFTPClientHandshake { -- | agreed XFTP server protocol version xftpVersion :: VersionXFTP, -- | server identity - CA certificate fingerprint - keyHash :: C.KeyHash + keyHash :: C.KeyHash, + -- | proof of the user entitlement bound to the session + entitlementProof :: Maybe EntitlementProof } instance Encoding XFTPClientHello where @@ -147,12 +150,13 @@ instance Encoding XFTPClientHello where pure XFTPClientHello {webChallenge} instance Encoding XFTPClientHandshake where - smpEncode XFTPClientHandshake {xftpVersion, keyHash} = - smpEncode (xftpVersion, keyHash) + smpEncode XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} = + smpEncode (xftpVersion, keyHash, entitlementProof) smpP = do (xftpVersion, keyHash) <- smpP + entitlementProof <- smpP <|> pure Nothing Tail _compat <- smpP - pure XFTPClientHandshake {xftpVersion, keyHash} + pure XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} instance Encoding XFTPServerHandshake where smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} = diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 36dbcedae..d772e46d5 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -172,7 +172,6 @@ data SndFile = SndFile status :: SndFileStatus, deleted :: Bool, redirect :: Maybe RedirectFileInfo, - entitlementCredential :: Maybe EntitlementCredential, storageTime :: Maybe Int64 } deriving (Show) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d6fe750e5..3522596d2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -108,6 +108,7 @@ module Simplex.Messaging.Agent getConnectionServers, getConnectionRatchetAdHash, setProtocolServers, + setUserEntitlement, checkUserServers, testProtocolServer, setNtfServers, @@ -774,8 +775,8 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c {-# INLINE xftpDeleteRcvFiles #-} -- | Send XFTP file -xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId -xftpSendFile c = withAgentEnv c .::. xftpSendFile' c +xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Int64 -> AE SndFileId +xftpSendFile c = withAgentEnv c .:: xftpSendFile' c {-# INLINE xftpSendFile #-} -- | Send XFTP file @@ -3050,6 +3051,13 @@ setProtocolServers c userId srvs = do checkUserServers "setProtocolServers" srvs atomically $ TM.insert userId (mkUserServers srvs) (userServers c) +-- | Change the entitlement credential presented to XFTP servers for the user. +-- The credential is presented in the handshake, so the user's XFTP clients are closed to present the new one. +setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO () +setUserEntitlement c userId cred_ = do + atomically $ maybe (TM.delete userId) (TM.insert userId) cred_ $ userEntitlements c + closeUserXFTPClients c userId + checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () checkUserServers name srvs = unless (any (\ServerCfg {enabled} -> enabled) srvs) $ diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 94c5e22f8..5bcdf8a54 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Client reconnectServerClients, reconnectSMPServer, closeXFTPServerClient, + closeUserXFTPClients, runSMPServerTest, runXFTPServerTest, runNTFServerTest, @@ -233,7 +234,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, xftpNewProofHeader) +import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) 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 +254,8 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs) import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), generateEntitlementProof) +import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..), BBSPublicKey) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), EntitlementProof, generateEntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client @@ -355,6 +357,7 @@ data AgentClient = AgentClient ntfClients :: TMap NtfTransportSession NtfClientVar, xftpServers :: TMap UserId (UserServers 'PXFTP), xftpClients :: TMap XFTPTransportSession XFTPClientVar, + userEntitlements :: TMap UserId EntitlementCredential, useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks presetDomains :: [HostName], presetServers :: [SMPServer], @@ -512,7 +515,7 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient -newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do +newAgentClient clientId InitialAgentServers {smp, ntf, xftp, entitlements, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do let cfg = config agentEnv qSize = tbqSize cfg proxySessTs <- newTVarIO =<< getCurrentTime @@ -528,6 +531,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices ntfClients <- TM.emptyIO xftpServers <- newTVarIO $ M.map mkUserServers xftp xftpClients <- TM.emptyIO + userEntitlements <- newTVarIO entitlements useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg) userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True userNetworkUpdated <- newTVarIO Nothing @@ -569,6 +573,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices ntfClients, xftpServers, xftpClients, + userEntitlements, useNetworkConfig, presetDomains, presetServers, @@ -879,7 +884,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, pr logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient -getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(_, srv, _) = do +getXFTPServerClient c@AgentClient {active, xftpClients, userEntitlements, workerSeq, proxySessTs, presetDomains} tSess@(userId, srv, _) = do unlessM (readTVarIO active) $ throwE INACTIVE ts <- liftIO getCurrentTime withGetSessVar workerSeq tSess xftpClients ts (newProtocolClient c tSess xftpClients connectClient) (waitForProtocolClient c NRMBackground tSess xftpClients) @@ -887,12 +892,22 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, connectClient :: XFTPClientVar -> AM XFTPClient connectClient v = do cfg <- asks $ xftpCfg . config + keys <- asks $ entitlementKeys . config xftpNetworkConfig <- getNetworkConfig c ts <- readTVarIO proxySessTs liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $ - X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $ + X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (mkEntitlementProof keys) $ clientDisconnected v + mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof) + mkEntitlementProof keys sessId = + TM.lookupIO userId userEntitlements + $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys) + $>>= \pk -> generateEntitlementProof pk cred (BBSPresHeader sessId) + >>= \case + Right p -> pure $ Just p + Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) + clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients @@ -1038,6 +1053,15 @@ reconnectSMPServer c userId srv = do | userId == userId' && srv == srv' = (v :) | otherwise = id +closeUserXFTPClients :: AgentClient -> UserId -> IO () +closeUserXFTPClients c userId = do + cs <- readTVarIO $ xftpClients c + mapM_ (forkIO . closeClient_ c) $ M.foldrWithKey userClient [] cs + where + userClient (userId', _, _) v + | userId == userId' = (v :) + | otherwise = id + closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () closeClient c clientSel tSess = atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c) @@ -1338,7 +1362,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure ()) >>= \case + X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case Right xftp -> withTestChunk filePath $ do (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -1346,7 +1370,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 Nothing Nothing + (sId, [rId], _) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth 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,27 +2211,17 @@ 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 -> Maybe Int64 -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) credential storageTime = do +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Int64 -> AM NewSndChunkReplica +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageTime = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - keys <- asks $ entitlementKeys . config - (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> do - proof <- liftIO $ mkEntitlementProof keys (sessionId $ X.thParams xftp) sndKey - X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof + (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> + X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt} - where - mkEntitlementProof keys sessId sndKey = - pure credential - $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys) - $>>= \pk -> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey chunkDigest) - >>= \case - Right p -> pure $ Just p - Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 709a44674..bb066f35b 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -68,7 +68,7 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationErro import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSPublicKey) -import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential, entitlementIssuerKeys) import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) @@ -91,6 +91,7 @@ data InitialAgentServers = InitialAgentServers { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)), ntf :: [NtfServer], xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)), + entitlements :: Map UserId EntitlementCredential, netCfg :: NetworkConfig, useServices :: Map UserId Bool, presetDomains :: [HostName], diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index d4cfc3b34..b472cb5b7 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -3425,13 +3425,13 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -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 = +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Int64 -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageTime = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, entitlement_credential, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) + "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageTime)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3467,7 +3467,7 @@ getSndFile db sndFileId = runExceptT $ do DB.query db ( [sql| - SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, entitlement_credential, storage_time + SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, storage_time FROM snd_files WHERE snd_file_id = ? |] @@ -3477,12 +3477,12 @@ getSndFile db sndFileId = runExceptT $ do ) (Only sndFileId) where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe EntitlementCredential, Maybe Int64) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) = + 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 Int64) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageTime)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, entitlementCredential, storageTime, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageTime, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- 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 b3fb2938e..c1e7dcf1b 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 @@ -9,7 +9,6 @@ import Text.RawString.QQ (r) m20260823_snd_files_entitlement :: Text m20260823_snd_files_entitlement = [r| -ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; ALTER TABLE snd_files ADD COLUMN storage_time BIGINT; ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at BIGINT; |] @@ -19,5 +18,4 @@ down_m20260823_snd_files_entitlement = [r| ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at; ALTER TABLE snd_files DROP COLUMN storage_time; -ALTER TABLE snd_files DROP COLUMN entitlement_credential; |] diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql index 465c569a5..101a0f3d4 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql @@ -742,7 +742,6 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_files ( failed smallint DEFAULT 0, redirect_size bigint, redirect_digest bytea, - entitlement_credential text, storage_time bigint ); 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 48bd1209d..1a79b63d3 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 @@ -8,7 +8,6 @@ import Database.SQLite.Simple.QQ (sql) m20260823_snd_files_entitlement :: Query m20260823_snd_files_entitlement = [sql| -ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; ALTER TABLE snd_files ADD COLUMN storage_time INTEGER; ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at INTEGER; |] @@ -18,5 +17,4 @@ down_m20260823_snd_files_entitlement = [sql| ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at; ALTER TABLE snd_files DROP COLUMN storage_time; -ALTER TABLE snd_files DROP COLUMN entitlement_credential; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index a24249e83..6ea5d9b53 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -353,7 +353,6 @@ CREATE TABLE snd_files( failed INTEGER DEFAULT 0, redirect_size INTEGER, redirect_digest BLOB, - entitlement_credential TEXT, storage_time INTEGER ) STRICT; CREATE TABLE snd_file_chunks( @@ -378,6 +377,8 @@ CREATE TABLE snd_file_chunk_replicas( retries INTEGER NOT NULL DEFAULT 0, created_at TEXT NOT NULL DEFAULT(datetime('now')), updated_at TEXT NOT NULL DEFAULT(datetime('now')) + , + replica_expires_at INTEGER ) STRICT; CREATE TABLE snd_file_chunk_replica_recipients( snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY, diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 837f31fa2..7fafeeeab 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -132,7 +132,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer ntfThHandleServer th v vr pk = - let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing} + let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = Nothing, sessSecret' = Nothing} in ntfThHandle_ th v vr (Just thAuth) ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index fbab1b01c..16ad58ab3 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -2132,7 +2132,7 @@ client t' <- case tParse clntTHParams b of t :| [] -> pure $ tDecodeServer clntTHParams t _ -> throwE BLOCK - let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, sessSecret' = Just clientSecret} + let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, peerEntitlement = Nothing, sessSecret' = Just clientSecret} encodeResp r = do r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 9c9392c21..a366e79f7 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -84,6 +84,8 @@ module Simplex.Messaging.Transport THandle (..), THandleParams (..), THandleAuth (..), + SessionEntitlement (..), + EntitlementConfig (..), CertChainPubKey (..), ServiceCredentials (..), THClientService' (..), @@ -119,6 +121,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Default (def) import Data.Functor (($>)) +import Data.Int (Int64) import Data.Kind (Type) import Data.Tuple (swap) import Data.Typeable (Typeable) @@ -136,6 +139,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON) import Simplex.Messaging.Server.Information +import Simplex.Messaging.SystemTime (SystemSeconds) import Simplex.Messaging.Transport.Buffer import Simplex.Messaging.Transport.Shared import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>)) @@ -483,10 +487,15 @@ data THandleAuth (p :: TransportPeer) where THAuthServer :: { serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key peerClientService :: Maybe THPeerClientService, + peerEntitlement :: Maybe SessionEntitlement, -- verified in the handshake, applies to the whole session sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only) } -> THandleAuth 'TServer +data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig} + +newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64} + type THClientService = THClientService' C.PrivateKeyEd25519 type THPeerClientService = THClientService' C.PublicKeyEd25519 @@ -801,7 +810,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer) smpTHandleServer th v vr pk k_ proxyServer peerClientService = do - let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_} + let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, peerEntitlement = Nothing, sessSecret' = (`C.dh'` pk) <$!> k_} be <- blockEncryption th proxyServer thAuth pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 9c58c59eb..c89e84409 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 Nothing + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2" -- Left e <- getNextSndFileToPrepare db 86400 @@ -809,13 +809,13 @@ testGetNextSndChunkToUpload st = do Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400 -- create file 1 - Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing Nothing + Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce 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 Nothing + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] createSndFileReplica_ db 2 newSndChunkReplica1 diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index 01ceeff16..e95d0a2ad 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -63,6 +63,7 @@ initServers = { smp = M.fromList [(1, testSMPServers)], ntf = [testNtfServer], xftp = userServers [testXFTPServer], + entitlements = M.empty, netCfg = defaultNetworkConfig, useServices = M.empty, presetDomains = [], diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index d375b6c21..159460828 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -64,6 +64,7 @@ initAgentServers = { smp = userServers [testSMPServer], ntf = [testNtfServer], xftp = userServers [testXFTPServer], + entitlements = M.empty, netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000}, useServices = M.empty, presetDomains = [], diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index d1019231f..a26787d01 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -50,6 +50,7 @@ import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Server.Information (ServerPublicInfo) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) @@ -346,13 +347,14 @@ testXFTPAgentEntitlement = do let ent = Entitlement {entitlementName = "supporter", expiresAt = addUTCTime (30 * nominalDay) now, extraInfo = ""} keys = M.fromList [(1, issuerPk)] Right credential <- signEntitlement issuerSk 1 (MasterKey "0123456789abcdef0123456789abcdef") ent - let srvCfg = testXFTPServerConfig {entitlementKeys = keys, fileStorageEntitlements = M.fromList [("supporter", 168 * 3600)]} + let srvCfg = testXFTPServerConfig {entitlementKeys = keys, fileStorageEntitlements = M.fromList [("supporter", EntitlementConfig (168 * 3600))]} withXFTPServerCfg srvCfg $ \_ -> do filePath <- createRandomFile_ (kb 128 :: Integer) "testfile" - withAgent 1 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB $ \sndr -> runRight_ $ do + let servers = initAgentServers {AEnv.entitlements = M.fromList [(1, credential)]} + withAgent 1 (agentCfg {AEnv.entitlementKeys = keys}) servers testDB $ \sndr -> runRight_ $ do xftpStartWorkers sndr (Just senderFiles) nowSec <- liftIO $ systemSeconds <$> getSystemTime - _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just credential) (Just 100) + _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just 100) gExpires <- waitSndDone sndr liftIO $ case gExpires of Just (GSTExpires t) -> do diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 2b28348fb..203c8d826 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -33,7 +33,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) #endif -xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing Nothing +xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s) @@ -220,7 +220,7 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClientWith cfg client = do ts <- getCurrentTime - getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case + getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case Right c -> client c Left e -> error $ show e diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 5be3b9c53..f0682e83b 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -103,7 +103,7 @@ createTestChunk fp = do pure bytes createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing Nothing +createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing readChunk :: XFTPFileId -> IO ByteString readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ unEntityId sId)) @@ -251,7 +251,7 @@ testInactiveClientExpiration :: AFStoreType -> Expectation testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do disconnected <- newEmptyTMVarIO ts <- liftIO getCurrentTime - c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ()) + c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> pure Nothing) (\_ -> atomically $ putTMVar disconnected ()) pingXFTP c liftIO $ do threadDelay 100000 @@ -543,7 +543,7 @@ testWebHandshake = -- Verify signedPubKey (DH key auth) void $ either error pure $ C.verifyX509 leafPubKey signedPubKey -- Send client handshake with echoed challenge - let clientHs = XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash} + let clientHs = XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash, entitlementProof = Nothing} clientHsPadded <- either (error . show) pure $ C.pad (smpEncode clientHs) xftpBlockSize let clientHsReq = H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded resp2 <- either (error . show) pure =<< HC.sendRequest h2 clientHsReq (Just 5000000) @@ -569,7 +569,7 @@ testWebReHandshake = resp1 <- either (error . show) pure =<< HC.sendRequest h2 helloReq1 (Just 5000000) serverHs1 <- either (error . show) pure $ C.unPad (bodyHead (HC.respBody resp1)) XFTPServerHandshake {sessionId = sid1} <- either error pure $ smpDecode serverHs1 - clientHsPadded <- either (error . show) pure $ C.pad (smpEncode (XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash})) xftpBlockSize + clientHsPadded <- either (error . show) pure $ C.pad (smpEncode (XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash, entitlementProof = Nothing})) xftpBlockSize resp1b <- either (error . show) pure =<< HC.sendRequest h2 (H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded) (Just 5000000) B.length (bodyHead (HC.respBody resp1b)) `shouldBe` 0 -- Re-handshake on same connection with xftp-web-hello header