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 new file mode 100644 index 000000000..ec0e1c158 --- /dev/null +++ b/plans/2026-08-22-xftp-file-storage-time.md @@ -0,0 +1,168 @@ +# 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`: + +Types: + +``` +newtype MasterKey = MasterKey ByteString + +data Entitlement = Entitlement + { expiresAt :: UTCTime, + entitlementName :: Text, + extraInfo :: Text + } + +data EntitlementCredential = EntitlementCredential + { issuerKeyIdx :: Word16, + masterKey :: MasterKey, + entitlement :: Entitlement, + issuerSignature :: BBSSignature + } + +data EntitlementProof = EntitlementProof + { issuerKeyIdx :: Word16, + entitlement :: Entitlement, + entProof :: BBSProof + } +``` + +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 protocol encoding of `Entitlement` and its field order follow the same order +- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes +- `generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` (the issuer key is looked up by the credential's index; an absent index is `Left`) +- `verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification`, where `data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it) +- the issuer public keys constant `Map Word16 BBSPublicKey` + +## simplexmq: protocol, new XFTP version + +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`: + +- add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants: + +``` +data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} +``` + +- add the storage time (`Maybe Word32`: `Nothing` and `Just 0` request the server maximum, a value above zero requests that number of hours) to `FNEW` +- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version) + +## simplexmq: server configuration + +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`, into `fileStorageEntitlements :: Map Text EntitlementConfig`, where `newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64}` holds seconds; 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`); 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. `HandshakeSent` carries `EntitlementChecked`, so the first handshake verifies and every later one on that connection reuses the result, including after `processHello` returns the session to `HandshakeSent` +- verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum +- a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed +- `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise + +## simplexmq: server store and expiration + +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`, cap the requested hours at the session maximum, round the expiry up to the hour, store it, and return that same value as the granted storage +- `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 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: `(SELECT ... WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT ... WHERE expires_at IS NULL AND created_at < ? LIMIT ?)` with `(now, limit, old - fileTimePrecision, limit)`. 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. Each arm is one range over the composite index and stops at its own limit; a single `OR` predicate builds a bitmap of every match before the limit applies. 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. New files always store an expiry, so the second arm drains permanently once the legacy rows expire, and is then removed. + +Store log, in `Simplex.FileTransfer.Server.StoreLog`: + +- add the optional expiration to the `AddFile` record; a record without it parses to `Nothing` (the configured default), never a hardcoded value + +## 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 storage time (`Maybe Word32` hours) to `xftpSendFile` +- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and when the credential changed it closes that user's XFTP clients, so the next upload presents the new credential + +Store, in both the SQLite and PostgreSQL agent stores: + +- 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 storage time + +Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`: + +- `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 generates the proof over the session id from the configured issuer keys, and only for a server of this user, matched by the key hash that TLS pins, so a file description of the sender cannot direct the entitlement to another server. A server that is not the user's, 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: + +- `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` and `getNextSndChunkToUpload` read 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) + +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` 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 +- the expiry is written before the status, because `BlockingInfo`'s notice parser is terminal (`A.takeByteString`), so any field after the blocking info makes the record unparseable and the file is dropped on restart. Every field added to `AddFile` must go before the status +- 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, with and without the expiry, including a file blocked with a notice in both cases + +## 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 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 storage time, and the response. +3. Change the server configuration, store, expiration, and store log. +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/protocol/xftp.md b/protocol/xftp.md index 4180e652b..0d3a23ad8 100644 --- a/protocol/xftp.md +++ b/protocol/xftp.md @@ -1,4 +1,4 @@ -Version 3, 2025-01-24 +Version 4, 2026-08-08 # SimpleX File Transfer Protocol @@ -50,11 +50,12 @@ The objective of SimpleX File Transfer Protocol (XFTP) is to facilitate the secu XFTP is implemented as an application level protocol on top of HTTP2 and TLS. -This document describes XFTP protocol version 3. The version history: +This document describes XFTP protocol version 4. The version history: - v1: initial version - v2: authenticated commands - added basic auth support for commands - v3: blocked files - added BLOCKED error type for policy violations +- v4: server public information and entitlement proof in handshake, file storage time in FNEW and SIDS The protocol describes the set of commands that senders and recipients can send to XFTP routers to create, upload, download and delete data packets of several pre-defined sizes. XFTP routers SHOULD support packets of 4 sizes: 64KB, 256KB, 1MB and 4MB (1KB = 1024 bytes, 1MB = 1024KB). @@ -329,7 +330,7 @@ Once TLS handshake is complete, client and router will exchange blocks of fixed ```abnf paddedRouterHello = -routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey ignoredPart +routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey webIdentityProof serverInfo ignoredPart xftpVersionRange = minXftpVersion maxXftpVersion minXftpVersion = xftpVersion maxXftpVersion = xftpVersion @@ -338,15 +339,27 @@ sessionIdentifier = shortString routerCerts = length 1*routerCert ; NonEmpty list of certificates in chain routerCert = originalLength signedRouterKey = originalLength ; signed by router certificate +webIdentityProof = shortString ; signature over the web client challenge and sessionIdentifier, empty when the client sent no challenge +serverInfo = %s"0" / (%s"1" largeString) ; JSON server public information, sent when maxXftpVersion is 4 or above paddedClientHello = -clientHello = xftpVersion keyHash ignoredPart +clientHello = xftpVersion keyHash entitlementProof ignoredPart ; chosen XFTP protocol version - must be the maximum supported version ; within the range offered by the router +entitlementProof = %s"0" / (%s"1" issuerKeyIndex bbsProof entitlement) +; proof of the user entitlement, encoded from v4, bound to sessionIdentifier +issuerKeyIndex = 2*2OCTET ; Word16 index of the issuer public key +bbsProof = largeString +entitlement = entExpires entName entExtra +entExpires = shortString ; expiration as an ISO8601 UTC timestamp +entName = shortString ; e.g. "supporter", "legend" +entExtra = largeString ; opaque to the router + xftpVersion = 2*2OCTET ; Word16 version number keyHash = shortString shortString = length length*OCTET +largeString = originalLength *OCTET length = 1*1OCTET originalLength = 2*2OCTET ignoredPart = *OCTET @@ -432,7 +445,7 @@ Routers SHOULD support basic auth with this command, to allow only router owners The syntax is: ```abnf -register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth +register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth fileStorageTime fileInfo = sndKey size digest sndKey = length x509encoded size = 4*4 OCTET ; Word32 big-endian @@ -440,19 +453,27 @@ digest = length *OCTET rcvPublicAuthKeys = length 1*rcvPublicAuthKey rcvPublicAuthKey = length x509encoded basicAuth = "0" / "1" length *OCTET +fileStorageTime = %s"0" / (%s"1" storageHours) +; encoded from v4; absent or zero requests the maximum the router allows +storageHours = 4*4 OCTET ; Word32 big-endian x509encoded = length = 1*1 OCTET ``` +`fileStorageTime` requests how long the router stores the data packet. The router grants the smaller of the request and the maximum it allows for the entitlement presented in the handshake, and returns the granted expiration in `sndIds`. + If the data packet is registered successfully, the router must send `sndIds` response with the sender's and recipients' data packet IDs: ```abnf -sndIds = %s"SIDS " senderId recipientIds +sndIds = %s"SIDS " senderId recipientIds grantedStorageTime senderId = length *OCTET recipientIds = length 1*recipientId recipientId = length *OCTET +grantedStorageTime = %s"0" / (%s"1" grantedExpires) ; encoded from v4 +grantedExpires = %s"T" expiresAt +expiresAt = 8*8 OCTET ; Int64 big-endian, seconds since epoch ``` #### Add data packet recipients 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..de00a441f --- /dev/null +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -0,0 +1,109 @@ +# XFTP variable file storage time + +## Summary + +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 + +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 = entExpires entName entExtra +entExpires = shortString ; expiration as a UTCTime ISO8601 string +entName = shortString ; e.g. "supporter", "legend" +entExtra = largeString ; opaque, interpretation out of scope + +entitlementProof = issuerKeyIndex bbsProof entitlement +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 takes it from the session (see [Binding](#binding)), which is what binds the proof. + +### Issuer keys + +Client apps and servers share one list of issuer public keys, indexed by `issuerKeyIndex`. The secret key for the current index is held by the service that issues entitlements, on conditions that are out of scope here, such as payment. + +The list holds eight keys so that the issuing service can rotate its current key without an app or server release: the next index is already known to every app and server. Each rotation consumes one index, so a new key has to be added to client apps and servers eventually, and released before the list is exhausted. + +## Storage time + +``` +fileStorageTime = %s"0" / (%s"1" storageHours) +storageHours = 4*4 OCTET ; Word32, network byte order +``` + +The storage time is an optional number of hours. Absent (`%s"0"`), or present as zero hours, requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value above zero requests that number of hours, and the server grants the smaller of it and the maximum. + +## Handshake, new XFTP version + +The client handshake carries the entitlement proof. + +``` +clientHandshake = xftpVersion keyHash optEntitlementProof +optEntitlementProof = %s"0" / (%s"1" entitlementProof) +``` + +`xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof. + +The server verifies the proof when it accepts the handshake and keeps the result for the session; further handshakes on the same connection keep that result and verify nothing, so a session costs one verification however many handshakes it makes. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures. + +## Commands + +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 + +FNEW extends the SIDS response with the granted storage. + +``` +sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime +optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime) +grantedStorageTime = grantedExpires +grantedExpires = %s"T" expiresAt +expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order +``` + +`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 + +The presentation header binds the proof to the TLS session, so a proof presented on any other session fails to verify. + +``` +presHeader = sessionId +``` + +`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. + +BBS proofs of one credential are unlinkable, but every proof discloses the same `entExpires`, `entName` and `entExtra`, so a server can link the sessions of one holder by that triple, and two servers can correlate them. The issuing service decides how identifying it is: `entExpires` set to the same instant for everyone who buys in the same period, and an `entExtra` that carries nothing per-holder, make the holders of that period indistinguishable. + +## Maximum storage time + +The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server honours an entitlement for 24 hours after its expiration; past that grace it is treated as no proof. + +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 + +``` +shortString = length *OCTET ; 0-255 bytes +largeString = length2 *OCTET +length = 1*1 OCTET +length2 = 2*2 OCTET ; Word16, network byte order +``` + +`senderId`, `rcvIds`, `fileInfo`, `sndKey`, `digest`, `rcvKeys`, `optBasicAuth`, and `sessionId` are defined by the current XFTP and SMP protocols. diff --git a/simplexmq.cabal b/simplexmq.cabal index db6c0f31d..8d331c4a3 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: simplexmq -version: 7.1.0.4 +version: 7.1.0.5 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -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 @@ -192,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 @@ -245,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..005dd6dbe 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -50,11 +50,12 @@ import qualified Data.Set as S import Data.Text (Text, pack) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Word (Word32) 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 @@ -350,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 -> AM SndFileId -xftpSendFile' c userId file numRecipients = do +xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId +xftpSendFile' c userId file numRecipients storageHours = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath @@ -359,7 +360,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 storageHours lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -375,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} + 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 @@ -405,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} <- + SndFile {numRecipients, chunks, storageHours} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath @@ -424,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' + srvs <- forM pendingChunks $ createChunk numRecipients' storageHours let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -454,8 +455,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 Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk numRecipients' storageHours ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica @@ -482,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 + replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageHours pure (replica, srvAuth) sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () @@ -543,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 @@ -577,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 chunks' = fmap minimum $ L.nonEmpty =<< mapM chunkExpiresAt chunks' + 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 a5cd4acfe..8ff212d57 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -36,8 +36,10 @@ 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 qualified Data.Aeson as J import Data.Bifunctor (first) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) @@ -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 (..), @@ -84,7 +87,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 @@ -126,8 +129,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 @@ -146,21 +149,23 @@ 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 - shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake +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, serverInfoBytes} <- 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} + serverInfo = J.eitherDecodeStrict' <$> serverInfoBytes + pure thParams0 {thAuth, thVersion = v, thServerVRange = vr, serverInfo} where getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake getServerHandshake = do @@ -253,10 +258,11 @@ createXFTPChunk :: FileInfo -> 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) + Maybe Word32 -> + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) +createXFTPChunk c spKey file rcps auth_ storageHours = + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageHours) Nothing >>= \case + (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs) (r, _) -> throwE $ unexpectedResponse r addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) 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 fae8a6d0b..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 + (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 763142c72..50c84e711 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -22,6 +22,7 @@ module Simplex.FileTransfer.Protocol FileCommand (..), FileCmd (..), FileInfo (..), + GrantedStorageTime (..), XFTPFileId, FileResponse (..), xftpBlockSize, @@ -38,12 +39,13 @@ 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.Encoding @@ -175,7 +177,7 @@ 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 -> Maybe Word32 -> FileCommand FSender FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender @@ -196,12 +198,27 @@ data FileInfo = FileInfo } deriving (Show) +data GrantedStorageTime = GSTExpires {epochSeconds :: Int64} + deriving (Eq, Ord, Show) + +instance Encoding GrantedStorageTime where + smpEncode = \case + GSTExpires t -> smpEncode ('T', t) + smpP = + smpP >>= \case + 'T' -> GSTExpires <$> smpP + _ -> fail "bad GrantedStorageTime" + 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 + | v >= fileStorageTimeXFTPVersion -> fnew <> e st + | otherwise -> fnew + where + fnew = e (FNEW_, ' ', file, rKeys, auth_) FADD rKeys -> e (FADD_, ' ', rKeys) FPUT -> e FPUT_ FDEL -> e FDEL_ @@ -235,10 +252,14 @@ 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 -> fnewP smpP + | otherwise -> fnewP (pure Nothing) + where + fnewP stP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL @@ -292,7 +313,7 @@ instance ProtocolMsgTag FileResponseTag where _ -> Nothing data FileResponse - = FRSndIds SenderId (NonEmpty RecipientId) + = FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime) | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey C.CbNonce | FROk @@ -303,7 +324,9 @@ 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) FROk -> e FROk_ @@ -315,8 +338,10 @@ 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 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 9f7499782..74a6f5ed5 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -23,18 +23,22 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Trans.Except +import qualified Data.Aeson as J import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L +import qualified Data.Map.Strict as M 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.System (systemSeconds, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) import qualified Data.X509 as X @@ -54,6 +58,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 (..), EntitlementVerification (..), verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -66,7 +72,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) @@ -120,17 +126,20 @@ runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s -> runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) data Handshake - = HandshakeSent C.PrivateKeyX25519 + = HandshakeSent C.PrivateKeyX25519 EntitlementChecked | HandshakeAccepted (THandleParams XFTPVersion 'TServer) +-- | the entitlement of the session is resolved once, however many handshakes it has +data EntitlementChecked = EntNotChecked | EntChecked (Maybe SessionEntitlement) + xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () -xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do - mapM_ (expireServerFiles Nothing) fileExpiration +xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange, information} started = do + expireServerFiles Nothing fileExpiration restoreServerStats raceAny_ ( runServer - : expireFilesThread_ cfg - <> serverStatsThread_ cfg + : expireFiles fileExpiration + : serverStatsThread_ cfg <> prometheusMetricsThread_ cfg <> controlPortThread_ cfg ) @@ -174,12 +183,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira Nothing | sniUsed && not webHello -> throwE SESSION | otherwise -> processHello Nothing - Just (HandshakeSent pk) + Just (HandshakeSent pk ent_) | webHello -> processHello (Just pk) - | otherwise -> processClientHandshake pk + | otherwise -> processClientHandshake pk ent_ Just (HandshakeAccepted thParams) | webHello -> processHello (serverPrivKey <$> thAuth thParams) - | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) + | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (EntChecked $ peerEntitlement auth) | otherwise -> pure $ Just thParams either sendError pure r where @@ -196,28 +205,35 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira | otherwise -> throwE HANDSHAKE rng <- asks random k <- atomically $ TM.lookup sessionId sessions >>= \case - Just (HandshakeSent pk') -> pure $ C.publicKey pk' - _ -> do + Just (HandshakeSent pk' _) -> pure $ C.publicKey pk' + s' -> do kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_ - fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions + let ent_ = case s' of + Just (HandshakeAccepted thParams) -> EntChecked $ peerEntitlement =<< thAuth thParams + _ -> EntNotChecked + fst kp <$ TM.insert sessionId (HandshakeSent (snd kp) ent_) sessions let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k) webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_ - let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof} + serverInfoBytes = LB.toStrict . J.encode <$> information + let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes} shs <- encodeXftp hs #ifdef slow_servers lift randomDelay #endif liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs pure Nothing - processClientHandshake pk = do + processClientHandshake pk ent_ = 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 <- case ent_ of + EntChecked ent -> pure ent + EntNotChecked -> lift $ verifiedEntitlement entitlementProof + let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing} thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions #ifdef slow_servers @@ -226,6 +242,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 + EVValid -> 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 @@ -243,10 +272,6 @@ 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 @@ -402,8 +427,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea case xftpDecodeTServer thParams bodyHead of Right (Right t@(_, _, (corrId, fId, _))) -> do let THandleParams {thAuth} = thParams + ent = peerEntitlement =<< thAuth verifyXFTPTransmission thAuth t >>= \case - VRVerified req -> uncurry send =<< processXFTPRequest body req + VRVerified req -> uncurry send =<< processXFTPRequest ent body req VRFailed e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) @@ -443,7 +469,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) -> pure $ XFTPReqNew file rcps auth' st `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -464,9 +490,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 => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) +processXFTPRequest ent HTTP2Body {bodyPart} = \case + XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -483,29 +509,42 @@ processXFTPRequest HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse - createFile file rks = do + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse + createFile file rks storageHours = do st <- asks fileStore r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE - ts <- liftIO getFileTime + now <- liftIO getSystemSeconds + maxSeconds <- lift $ storageMaxSeconds now + let nowSeconds = roundedSeconds now + ts = RoundedSystemTime $ (nowSeconds `div` fileTimePrecision) * fileTimePrecision + secs = case storageHours of + Just hours | hours > 0 -> min maxSeconds (fromIntegral hours * 3600) + _ -> maxSeconds + fileExpiresAt = RoundedSystemTime $ ((nowSeconds + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts + 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 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 + pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt))) pure $ either FRErr id r - addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) - addFileRetry st file n ts = + storageMaxSeconds :: SystemSeconds -> M s Int64 + storageMaxSeconds now = do + defaultMax <- asks $ ttl . fileExpiration . config + 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 - 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 = @@ -640,24 +679,25 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo) -getFileTime :: IO RoundedFileTime -getFileTime = getRoundedSystemTime +entitlementValid :: SystemSeconds -> SystemSeconds -> Bool +entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s () expireServerFiles itemDelay expCfg = do st <- asks fileStore us <- asks usedStorage usedStart <- readTVarIO us + now <- liftIO getSystemSeconds old <- liftIO $ expireBeforeEpoch expCfg filesCount <- liftIO $ getFileCount st logNote $ "Expiration check: " <> tshow filesCount <> " files" - expireLoop st us old + 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 old = do - expired <- liftIO $ expiredFiles st old 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 -> @@ -670,7 +710,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 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 b816eb36b..852036af3 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -37,8 +37,11 @@ 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.Word (Word16, Word32) import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T @@ -62,8 +65,11 @@ import System.Directory (doesFileExist) import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport (VersionRangeXFTP) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Information (ServerPublicInfo) +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential) import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) @@ -88,7 +94,10 @@ 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, + -- | what each entitlement name grants + fileStorageEntitlements :: Map Text EntitlementConfig, + entitlementKeys :: Map Word16 BBSPublicKey, -- | timeout to receive file fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds @@ -97,6 +106,8 @@ data XFTPServerConfig s = XFTPServerConfig httpCredentials :: Maybe ServerCredentials, -- | XFTP client-server protocol version range xftpServerVRange :: VersionRangeXFTP, + -- | server public information sent in handshake and used to generate static mini-site + information :: Maybe ServerPublicInfo, -- stats config - see SMP server config logStatsInterval :: Maybe Int64, logStatsStartTime :: Int64, @@ -171,7 +182,13 @@ defaultFileExpiration = } 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 + belowDefault = M.filter ((< defaultMax) . storageTime) fileStorageEntitlements + unless (M.null belowDefault) $ do + forM_ (M.assocs belowDefault) $ \(name, EntitlementConfig {storageTime}) -> + logError $ "expire_files_hours_for_" <> name <> " is " <> tshow (storageTime `div` 3600) <> " hours, below expire_files_hours " <> tshow (defaultMax `div` 3600) <> " hours, server not started" + exitFailure random <- C.newRandom (store, storeLog) <- case serverStoreCfg of XSCMemory storeLogPath -> do @@ -196,7 +213,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) (Maybe Word32) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 070dc546f..b3515b492 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 @@ -13,14 +14,16 @@ module Simplex.FileTransfer.Server.Main xftpServerCLI_, ) where -import Control.Monad (unless, when) +import Control.Monad (forM_, 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.List (find) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -32,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 (..)) @@ -40,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) @@ -155,8 +160,14 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do \# db_pool_size = 10\n\n\ \# Write database changes to store log file\n\ \# db_store_log = off\n\n" - <> "# Expire files after the specified number of hours.\n" + <> "# Expire files after the specified number of hours.\n\ + \# The change only affects new files.\n" <> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n") + <> "# Expire files after the specified number of hours for the senders that present\n\ + \# a proof of the entitlement. Must not be below expire_files_hours.\n\ + \# The change only affects new files.\n\ + \# expire_files_hours_for_supporter = 168\n\ + \# expire_files_hours_for_legend = 504\n\n" <> "log_stats = off\n\ \\n\ \# Log interval for real-time Prometheus metrics\n\ @@ -235,13 +246,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) - printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do + printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, fileStorageEntitlements, inactiveClientExpiration} = 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) + forM_ (M.assocs fileStorageEntitlements) $ \(name, EntitlementConfig {storageTime}) -> + putStrLn $ "expiring files of " <> T.unpack name <> " after " <> showTTL storageTime putStrLn $ case inactiveClientExpiration of Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" _ -> "not expiring inactive clients" @@ -287,10 +298,11 @@ 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, + entitlementKeys = entitlementIssuerKeys, fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini @@ -306,6 +318,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do }, httpCredentials = httpCredentials_, xftpServerVRange = supportedFileServerVRange, + information = serverPublicInfo ini, logStatsInterval = logStats $> 86400, -- seconds logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "file-server-stats.daily.log", @@ -437,3 +450,10 @@ 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 EntitlementConfig +iniEntitlements ini = + M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")] + where + 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/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 66d19d6de..371a5eea4 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -55,6 +55,7 @@ data FileRec = FileRec filePath :: TVar (Maybe FilePath), recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, + expiresAt :: Maybe RoundedFileTime, fileStatus :: TVar ServerEntityStatus } @@ -74,7 +75,7 @@ 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 ()) addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ()) deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ()) @@ -84,7 +85,7 @@ class FileStoreClass s where deleteRecipient :: s -> RecipientId -> FileRec -> IO () getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey)) ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ()) - expiredFiles :: s -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] + expiredFiles :: s -> SystemSeconds -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)] getUsedStorage :: s -> IO Int64 getFileCount :: s -> IO Int @@ -107,9 +108,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 () @@ -166,14 +167,17 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - expiredFiles STMFileStore {files} old _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}) -> - if createdAt + fileTimePrecision < old - then do - path <- readTVarIO filePath - pure $ Just (sId, path, size) - else pure Nothing + fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) -> + let expired = case expiresAt of + Just e -> roundedSeconds e < roundedSeconds now + Nothing -> createdAt + fileTimePrecision < old + in if expired + then do + path <- readTVarIO filePath + pure $ Just (sId, path, size) + else pure Nothing getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files where @@ -184,12 +188,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..c9e83c4c5 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -55,6 +55,7 @@ import Simplex.Messaging.Transport (EntityId (..)) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.QueueStore.Postgres () import Simplex.Messaging.Server.StoreLog (openWriteStoreLog) +import Simplex.Messaging.SystemTime (roundedSeconds) import Simplex.Messaging.Util (firstRow, tshow) import System.Directory (renameFile) import System.Exit (exitFailure) @@ -82,17 +83,17 @@ 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 -> @@ -131,13 +132,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 +153,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 old 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 < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)" + (roundedSeconds now, limit, old - fileTimePrecision, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) @@ -174,21 +175,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 +244,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 +283,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 +327,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 +339,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..98122b523 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,17 @@ 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; +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 expires_at; +|] diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 48ebb175e..fe731ee2c 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -20,13 +20,13 @@ 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 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) @@ -42,7 +42,7 @@ 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 @@ -52,27 +52,37 @@ data FileStoreLogRecord instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) + 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) BlockFile sId info -> strEncode (Str "FBLK", sId, info) AckFile rId -> strEncode (Str "FACK", rId) + where + expE = maybe "" ((" " <>) . strEncode) 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) ] + where + addFileP = do + sId <- strP_ + file <- strP_ + createdAt <- strP + expiresAt <- optional _strP + status <- _strP <|> pure EntityActive + pure $ AddFile sId file createdAt expiresAt status 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 = logFileStoreRecord s .::. AddFile logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -102,8 +112,8 @@ 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 @@ -118,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, 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..4e63a5e9e 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, @@ -36,7 +37,6 @@ module Simplex.FileTransfer.Transport ) where -import Control.Applicative (optional) import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad @@ -56,13 +56,14 @@ 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 import Simplex.Messaging.Protocol (BlockingInfo, CommandError) import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Transport.HTTP2.File -import Simplex.Messaging.Util (bshow, tshow, (<$?>)) +import Simplex.Messaging.Util (bshow, tshow, (<$?>), (<$$>)) import Simplex.Messaging.Version import Simplex.Messaging.Version.Internal import System.IO (Handle, IOMode (..), withFile) @@ -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 @@ -124,14 +128,18 @@ data XFTPServerHandshake = XFTPServerHandshake -- | pub key to agree shared secrets for command authorization and entity ID encryption. authPubKey :: CertChainPubKey, -- | signed identity challenge from XFTPClientHello - webIdentityProof :: Maybe C.ASignature + webIdentityProof :: Maybe C.ASignature, + -- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= fileStorageTimeXFTPVersion + serverInfoBytes :: Maybe ByteString } 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 @@ -143,21 +151,33 @@ instance Encoding XFTPClientHello where pure XFTPClientHello {webChallenge} instance Encoding XFTPClientHandshake where - smpEncode XFTPClientHandshake {xftpVersion, keyHash} = - smpEncode (xftpVersion, keyHash) + smpEncode XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} = + smpEncode (v, keyHash) <> ifHasEntitlement v (smpEncode entitlementProof) "" smpP = do - (xftpVersion, keyHash) <- smpP + (v, keyHash) <- smpP + entitlementProof <- ifHasEntitlement v smpP (pure Nothing) Tail _compat <- smpP - pure XFTPClientHandshake {xftpVersion, keyHash} + pure XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} + +ifHasEntitlement :: VersionXFTP -> a -> a -> a +ifHasEntitlement v a b = if v >= fileStorageTimeXFTPVersion then a else b instance Encoding XFTPServerHandshake where - smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} = - smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof) + smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes} = + smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof) <> info + where + info = ifHasServerInfo (maxVersion xftpVersionRange) (smpEncode (Large <$> serverInfoBytes)) "" smpP = do (xftpVersionRange, sessionId, authPubKey) <- smpP - webIdentityProof <- optional $ C.decodeSignature <$?> smpP + -- decode the (length-prefixed) signature bytes deterministically: empty bytes decode to Nothing. + -- (Must not use `optional`, which would backtrack and leave the bytes for the parsers that follow.) + webIdentityProof <- C.decodeSignature <$?> smpP + serverInfoBytes <- ifHasServerInfo (maxVersion xftpVersionRange) (unLarge <$$> smpP) (pure Nothing) Tail _compat <- smpP - pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} + pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes} + +ifHasServerInfo :: VersionXFTP -> a -> a -> a +ifHasServerInfo v a b = if v >= fileStorageTimeXFTPVersion then a else b sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO () sendEncFile h send = go diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ff70b8f13..e9e4c1a85 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -39,6 +39,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Word (Word32) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (GrantedStorageTime (..)) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -167,7 +168,8 @@ data SndFile = SndFile prefixPath :: Maybe FilePath, status :: SndFileStatus, deleted :: Bool, - redirect :: Maybe RedirectFileInfo + redirect :: Maybe RedirectFileInfo, + storageHours :: Maybe Word32 } deriving (Show) @@ -225,7 +227,8 @@ data NewSndChunkReplica = NewSndChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, replicaKey :: C.APrivateAuthKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)] + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)], + expiresAt :: Maybe GrantedStorageTime } deriving (Show) @@ -237,7 +240,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.hs b/src/Simplex/Messaging/Agent.hs index 06295948f..552996d1b 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, @@ -187,7 +188,7 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) import Data.Traversable (mapAccumL) -import Data.Word (Word16) +import Data.Word (Word16, Word32) 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 (..)) @@ -211,6 +212,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 @@ -679,7 +681,7 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of SPSMP -> runSMPServerTest c nm userId srv - SPXFTP -> maybe (Right Nothing) Left <$> runXFTPServerTest c nm userId srv + SPXFTP -> runXFTPServerTest c nm userId srv SPNTF -> maybe (Right Nothing) Left <$> runNTFServerTest c nm userId srv -- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network @@ -773,8 +775,8 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c {-# INLINE xftpDeleteRcvFiles #-} -- | Send XFTP file -xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId -xftpSendFile c = withAgentEnv c .:. xftpSendFile' c +xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AE SndFileId +xftpSendFile c = withAgentEnv c .:: xftpSendFile' c {-# INLINE xftpSendFile #-} -- | Send XFTP file @@ -3049,6 +3051,17 @@ 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 + changed <- atomically $ do + prev_ <- TM.lookup userId $ userEntitlements c + if prev_ == cred_ + then pure False + else True <$ maybe (TM.delete userId) (TM.insert userId) cred_ (userEntitlements c) + when changed $ closeUserXFTPClients c userId + checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () checkUserServers name srvs = unless (any (\ServerCfg {enabled} -> enabled) srvs) $ diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 1890ac8bc..b1ee8c011 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, @@ -227,7 +228,7 @@ import Data.Text (Text) import Data.Text.Encoding import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime) -import Data.Word (Word16) +import Data.Word (Word16, Word32) import qualified Data.X509.Validation as XV import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) @@ -253,6 +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.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 @@ -354,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], @@ -511,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 @@ -527,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 @@ -568,6 +573,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices ntfClients, xftpServers, xftpClients, + userEntitlements, useNetworkConfig, presetDomains, presetServers, @@ -878,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) @@ -886,12 +892,28 @@ 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 = + ifM knownServer proof (pure Nothing) + where + -- the entitlement is presented only to the servers of this user, matched by key hash that TLS pins, + -- so a file description of the sender cannot direct it to another server + knownServer = maybe False (any (sameKeyHash . snd) . storageSrvs) <$> TM.lookupIO userId (xftpServers c) + sameKeyHash (ProtoServerWithAuth srv' _) = srvKeyHash srv' == srvKeyHash srv + srvKeyHash (ProtocolServer _ _ _ kh) = kh + proof = + TM.lookupIO userId userEntitlements $>>= \cred -> + generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case + Right p -> pure $ Just p + Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) + clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients @@ -1037,6 +1059,13 @@ reconnectSMPServer c userId srv = do | userId == userId' && srv == srv' = (v :) | otherwise = id +closeUserXFTPClients :: AgentClient -> UserId -> IO () +closeUserXFTPClients c userId = do + vs <- atomically $ stateTVar (xftpClients c) $ \cs -> + let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs + in (M.elems userCs, cs') + mapM_ (forkIO . closeClient_ c) vs + closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () closeClient c clientSel tSess = atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c) @@ -1326,7 +1355,7 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure testErr step = ProtocolTestFailure step . protocolClientError SMP addr -runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure) +runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do cfg <- asks $ xftpCfg . config g <- asks random @@ -1337,7 +1366,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 @@ -1345,15 +1374,15 @@ 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 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 unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp - pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok - Left e -> pure (Just $ testErr TSConnect e) + pure $ r >> maybe (Left (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const $ Right $ serverInfo (X.thParams xftp)) ok + Left e -> pure $ Left (testErr TSConnect e) where addr = B.unpack $ strEncode srv testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure @@ -2186,16 +2215,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 -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageHours = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp -> + X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageHours 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} 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 c8a98264f..bb066f35b 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 (EntitlementCredential, entitlementIssuerKeys) import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Transport (NTFVersion) @@ -89,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], @@ -148,6 +151,7 @@ data AgentConfig = AgentConfig smpCfg :: ProtocolClientConfig SMPVersion, ntfCfg :: ProtocolClientConfig NTFVersion, xftpCfg :: XFTPClientConfig, + entitlementKeys :: Map Word16 BBSPublicKey, reconnectInterval :: RetryInterval, messageRetryInterval :: RetryInterval2, userNetworkInterval :: Int, @@ -226,6 +230,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/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 04fbcf729..e9946cca0 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.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) @@ -3424,13 +3424,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 Word32 -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageHours = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) 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, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageHours)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3466,7 +3466,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, storage_time FROM snd_files WHERE snd_file_id = ? |] @@ -3476,12 +3476,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 Word32) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageHours)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageHours, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- @@ -3510,7 +3510,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 @@ -3521,10 +3521,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 = @@ -3605,16 +3605,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 @@ -3660,7 +3660,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do SELECT f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path, c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest, - 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 FROM snd_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id @@ -3674,8 +3674,8 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do pure (replica :: SndFileChunkReplica) {rcvIdsKeys} pure (chunk {replicas = replicas'} :: SndFileChunk) where - toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk - toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) = + toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64)) -> SndFileChunk + toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec)) = let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} in SndFileChunk { sndFileId, @@ -3687,7 +3687,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 = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}] } updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () 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..c1e7dcf1b --- /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 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; +|] 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..60496f79e 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 @@ -682,7 +682,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_file_chunk_replicas ( delay bigint, retries bigint DEFAULT 0 NOT NULL, created_at timestamp with time zone DEFAULT now() NOT NULL, - updated_at timestamp with time zone DEFAULT now() NOT NULL + updated_at timestamp with time zone DEFAULT now() NOT NULL, + replica_expires_at bigint ); @@ -741,7 +742,8 @@ 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, + storage_time bigint ); 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..1a79b63d3 --- /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 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; + |] 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..6ea5d9b53 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,8 @@ CREATE TABLE snd_files( src_file_nonce BLOB, failed INTEGER DEFAULT 0, redirect_size INTEGER, - redirect_digest BLOB + redirect_digest BLOB, + storage_time INTEGER ) STRICT; CREATE TABLE snd_file_chunks( snd_file_chunk_id INTEGER PRIMARY KEY, @@ -376,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/Crypto/BBS.hs b/src/Simplex/Messaging/Crypto/BBS.hs index 7b19ca004..cdbb9a792 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.BBS BBSProof (..), BBSHeader (..), BBSPresHeader (..), + FixedBS (..), bbsKeyGen, bbsPublicKey, bbsSign, @@ -33,7 +34,9 @@ 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 Simplex.Messaging.Util ((<$?>)) import System.IO.Unsafe (unsafePerformIO) -- Note: the data constructors below are unchecked escape hatches for trusted, @@ -71,8 +74,8 @@ newtype BBSPresHeader = BBSPresHeader ByteString deriving (ToJSON, FromJSON) via (StrJSON "BBSPresHeader" BBSPresHeader) -- | A ByteString validated to be exactly @n@ bytes when parsed via StrEncoding --- (and the JSON derived from it). Local to BBS, where every key/signature is a --- fixed size; @name@ appears in the decode error only. +-- (and the JSON derived from it), for keys and signatures of a fixed size; +-- @name@ appears in the decode error only. newtype FixedBS (name :: Symbol) (n :: Nat) = FixedBS ByteString instance forall name n. (KnownSymbol name, KnownNat n) => StrEncoding (FixedBS name n) where @@ -97,14 +100,20 @@ bbsProofLen :: Int -> Int bbsProofLen numUndisclosed = bbsProofBaseLen + numUndisclosed * bbsProofUdElemLen -- | A proof is @bbsProofBaseLen + 32 * numUndisclosed@ bytes; reject anything else. +mkBBSProof :: ByteString -> Either String BBSProof +mkBBSProof bs + | len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 = Right $ BBSProof bs + | otherwise = Left $ "BBS: invalid proof length " <> show len + where + len = B.length bs + instance StrEncoding BBSProof where strEncode (BBSProof bs) = strEncode bs - strP = do - bs <- base64urlP - let len = B.length bs - if len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 - then pure (BBSProof bs) - else fail $ "BBS: invalid proof length " <> show len + strP = mkBBSProof <$?> base64urlP + +instance Encoding BBSProof where + smpEncode (BBSProof p) = smpEncode (Large p) + smpP = mkBBSProof . unLarge <$?> smpP -- FFI diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs new file mode 100644 index 000000000..5579df966 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Crypto.Entitlement + ( Entitlement (..), + EntitlementCredential (..), + EntitlementProof (..), + EntitlementVerification (..), + MasterKey (..), + randomMasterKey, + entitlementBBSHeader, + entitlementIssuerKeys, + signEntitlement, + verifyCredential, + generateEntitlementProof, + verifyEntitlement, + ) +where + +import Control.Concurrent.STM +import Crypto.Random (ChaChaDRG) +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 (decodeUtf8', encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word16) +import qualified Simplex.Messaging.Crypto as C +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) + deriving (StrEncoding) via (FixedBS "MasterKey" 32) + deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey) + +data Entitlement = Entitlement + { expiresAt :: UTCTime, + entitlementName :: Text, + extraInfo :: Text + } + deriving (Eq, Show) + +data EntitlementCredential = EntitlementCredential + { issuerKeyIdx :: Word16, + masterKey :: MasterKey, + entitlement :: Entitlement, + issuerSignature :: BBSSignature + } + deriving (Eq, Show) + +data EntitlementProof = EntitlementProof + { issuerKeyIdx :: Word16, + entitlement :: Entitlement, + entProof :: BBSProof + } + deriving (Eq, Show) + +data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer + deriving (Eq, Show) + +instance Encoding Entitlement where + smpEncode Entitlement {expiresAt, entitlementName, extraInfo} = + smpEncode (strEncode expiresAt, entitlementName, Large $ encodeUtf8 extraInfo) + smpP = do + (expBs, entitlementName, Large extraBs) <- smpP + expiresAt <- either fail pure $ strDecode (expBs :: ByteString) + extraInfo <- either (fail . show) pure $ decodeUtf8' extraBs + pure Entitlement {expiresAt, entitlementName, extraInfo} + +instance Encoding EntitlementProof where + smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} = + smpEncode (issuerKeyIdx, entProof, entitlement) + smpP = do + (issuerKeyIdx, entProof, entitlement) <- smpP + pure EntitlementProof {issuerKeyIdx, entProof, entitlement} + +entitlementBBSHeader :: BBSHeader +entitlementBBSHeader = BBSHeader "SimpleX badges 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 {expiresAt, entitlementName, extraInfo} = + [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] + +randomMasterKey :: TVar ChaChaDRG -> STM MasterKey +randomMasterKey g = MasterKey <$> C.randomBytes 32 g + +signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) +signEntitlement sk keyIdx mk ent = + EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent) + +verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool +verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} = + bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement) + +generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof) +generateEntitlementProof keys EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = + case M.lookup issuerKeyIdx keys of + Nothing -> pure $ Left $ "no issuer key " <> show issuerKeyIdx + Just pk -> EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) + +verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification +verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} = + case M.lookup issuerKeyIdx keys of + Nothing -> pure EVUnknownIssuer + Just pk -> + (\valid -> if valid then EVValid else EVInvalid) + <$> bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement) + +entitlementIssuerKeys :: Map Word16 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 BBSPublicKey") . strDecode . B.pack + +$(JQ.deriveJSON defaultJSON ''Entitlement) + +$(JQ.deriveJSON defaultJSON ''EntitlementCredential) + +$(JQ.deriveJSON defaultJSON ''EntitlementProof) 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 f50f694e2..fd461dfb3 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/Server/Main/GitCommit.hs b/src/Simplex/Messaging/Server/Main/GitCommit.hs index 03d8691b8..43489083b 100644 --- a/src/Simplex/Messaging/Server/Main/GitCommit.hs +++ b/src/Simplex/Messaging/Server/Main/GitCommit.hs @@ -6,14 +6,25 @@ module Simplex.Messaging.Server.Main.GitCommit ) where import Language.Haskell.TH +import Language.Haskell.TH.Syntax (addDependentFile) import System.Process import Control.Exception +import Control.Monad (filterM) +import System.Directory (doesFileExist) import System.Exit +import System.FilePath (()) gitCommit :: Q Exp -gitCommit = stringE . commit =<< runIO (try $ readProcessWithExitCode "git" ["rev-parse", "HEAD"] "") +gitCommit = + runIO gitHead >>= \case + Right (ExitSuccess, out, _) + | [commit, gitDir] <- lines out -> do + -- without these dependencies GHC recompilation check would not know that the commit changed. + -- HEAD reflog is updated on any HEAD change and, unlike branch ref files, git gc cannot remove it + -- mid-build; it is absent when reflogs are disabled, and addDependentFile fails on a missing file + mapM_ addDependentFile =<< runIO (filterM doesFileExist [gitDir "HEAD", gitDir "logs" "HEAD"]) + stringE commit + _ -> stringE "" where - commit :: Either SomeException (ExitCode, String, String) -> String - commit = \case - Right (ExitSuccess, out, _) -> take 40 out - _ -> "" + gitHead :: IO (Either SomeException (ExitCode, String, String)) + gitHead = try $ readProcessWithExitCode "git" ["rev-parse", "HEAD", "--git-dir"] "" diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index dc7f515ae..d2c30d25a 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -85,6 +85,8 @@ module Simplex.Messaging.Transport THandle (..), THandleParams (..), THandleAuth (..), + SessionEntitlement (..), + EntitlementConfig (..), CertChainPubKey (..), ServiceCredentials (..), THClientService' (..), @@ -120,6 +122,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) @@ -137,6 +140,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, (<$$>)) @@ -490,10 +494,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 @@ -808,7 +817,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/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index d831cdea7..cf6c3c8f6 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -54,6 +54,7 @@ module AgentTests.FunctionalAPITests pattern SENT, agentCfgVPrevPQ, agentCfgV7, + testServerInformation, ) where diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6aea60ff3..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 + 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 @@ -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 @@ -808,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 + 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 + 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/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index a7cf4f9ba..edeb097bf 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -7,14 +7,18 @@ module CoreTests.CryptoTests (cryptoTests) where import Control.Concurrent.STM +import Control.Exception (evaluate) import Control.Monad.Except import qualified Data.Aeson as J 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.Text.Encoding (encodeUtf8) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE import Data.Type.Equality @@ -25,6 +29,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 +124,9 @@ 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 + it "should decode all issuer keys" testEntitlementIssuerKeys instance Eq C.APublicKey where C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of @@ -444,3 +452,26 @@ 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" + Right cred <- signEntitlement sk 1 mk ent + verifyCredential pk cred `shouldReturn` True + Right proof <- generateEntitlementProof keys cred ph + verifyEntitlement keys ph proof `shouldReturn` EVValid + -- a different presentation header does not verify (session binding) + verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` EVInvalid + -- an unknown issuer key index is distinguished from an invalid proof + verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` EVUnknownIssuer + -- the protocol encoding of the proof roundtrips + smpDecode (smpEncode proof) `shouldBe` Right proof + +testEntitlementIssuerKeys :: IO () +testEntitlementIssuerKeys = do + mapM_ evaluate entitlementIssuerKeys + M.size entitlementIssuerKeys `shouldBe` 8 diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 01966ba05..13d831fe1 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,100 @@ 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" + +fileExpirationTests :: Spec +fileExpirationTests = + describe "XFTP file expiration" $ + it "expires by stored expiration and by creation time" testExpiredFiles + +testExpiredFiles :: Expectation +testExpiredFiles = do + st <- newFileStore () :: IO STMFileStore + g <- C.newRandom + (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + let file = FileInfo {sndKey, size = 16384, digest = "12345678"} + created = RoundedSystemTime 100000 + addFile st (EntityId "expired_stored__") file created (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right () + addFile st (EntityId "stored_ahead____") file created (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right () + addFile st (EntityId "legacy_expired__") file created Nothing EntityActive `shouldReturn` Right () + addFile st (EntityId "legacy_in_grace_") file (RoundedSystemTime 297000) Nothing EntityActive `shouldReturn` Right () + expired <- expiredFiles st (RoundedSystemTime 500000) 300000 100 + map (\(sId, _, _) -> sId) expired `shouldMatchList` [EntityId "expired_stored__", EntityId "legacy_expired__"] + +fileStoreLogTests :: Spec +fileStoreLogTests = do + g <- runIO C.newRandom + (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))] + }, + SLTC + { name = "block file without expiration", + saved = [AddFile sId file createdAt Nothing EntityActive, BlockFile sId blockedWithNotice], + compacted = [AddFile sId file createdAt Nothing (EntityBlocked blockedWithNotice)], + state = M.fromList [(sId, (file, createdAt, Nothing, EntityBlocked blockedWithNotice))] + } + ] + +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/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index 20c0e77fc..9f980b4ea 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -37,6 +37,7 @@ xftpStoreTests = do it "should block file and update status" testBlockFile it "should ack file reception" testAckFile it "should return expired files with limit" testExpiredFiles + it "should expire files by stored expiration" testExpiredFilesStoredExpiration it "should compute committed used storage and file count" testStorageAndCount xftpMigrationTests :: Spec @@ -68,6 +69,9 @@ testFileInfo sndKey = testCreatedAt :: RoundedFileTime testCreatedAt = RoundedSystemTime 1000000 +testExpiresAt :: RoundedFileTime +testExpiresAt = RoundedSystemTime 2000000 + -- Tests testAddGetFileSender :: Expectation @@ -75,7 +79,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 +96,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 +110,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 +123,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 +139,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 +149,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 +161,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 +175,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 +193,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 (RoundedSystemTime 500000) 500000 100 length expired `shouldBe` 1 case expired of [(sId, path, sz)] -> do @@ -202,6 +206,18 @@ testExpiredFiles = withPgStore $ \st -> do sz `shouldBe` 128000 _ -> expectationFailure "expected 1 expired file" +testExpiredFilesStoredExpiration :: Expectation +testExpiredFilesStoredExpiration = withPgStore $ \st -> do + g <- C.newRandom + (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + let fileInfo = testFileInfo sndKey + oldTime = RoundedSystemTime 100000 + -- both files are created before the cutoff, the stored expiration decides + addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right () + addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right () + expired <- expiredFiles st (RoundedSystemTime 500000) 0 100 + map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"] + testStorageAndCount :: Expectation testStorageAndCount = withPgStore $ \st -> do testStorageAndCountForStore st @@ -222,8 +238,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 +264,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 (Just testExpiresAt) EntityActive `shouldReturn` Right () void $ setFilePath stmStore sId1 "/tmp/file1" addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right () let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing} - 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 @@ -271,9 +287,10 @@ testMigrationRoundTrip = do -- Verify file 1 result1 <- getFile stmStore2 SFSender sId1 case result1 of - Right (FileRec {fileInfo = fi, filePath, fileStatus}, _) -> do + Right (FileRec {fileInfo = fi, filePath, expiresAt, fileStatus}, _) -> do size fi `shouldBe` 128000 readTVarIO filePath `shouldReturn` Just "/tmp/file1" + expiresAt `shouldBe` Just testExpiresAt readTVarIO fileStatus `shouldReturn` EntityActive Left e -> expectationFailure $ "getFile sId1 failed: " <> show e -- Verify recipient 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/Test.hs b/tests/Test.hs index c2968828b..5c135df4f 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -97,6 +97,8 @@ main = do #else describe "Store log tests" storeLogTests #endif + describe "XFTP store log tests" fileStoreLogTests + fileExpirationTests describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests describe "Names resolver tests" smpNamesTests diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 34da3d125..8237db2ab 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 #-} @@ -10,7 +11,7 @@ module XFTPAgent where -import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent) +import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent, testServerInformation) import Control.Logger.Simple import Control.Monad @@ -20,28 +21,37 @@ 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.Server.Env (AFStoreType, XFTPServerConfig (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..)) +import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..), defaultFileExpiration) import Simplex.FileTransfer.Server.Store (STMFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) -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 qualified Simplex.Messaging.Agent as XA 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 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 (..)) import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.Information (ServerPublicInfo) +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) import System.FilePath (()) @@ -56,6 +66,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 @@ -71,6 +84,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 @@ -83,7 +97,7 @@ xftpAgentTests = it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs describe "XFTP server test via agent API" $ do - it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right Nothing + it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right (Just (Right testServerInformation)) let srv1 = testXFTPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ \_ -> do testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) @@ -91,13 +105,13 @@ xftpAgentTests = let auth = Just "abcd" srv = ProtoServerWithAuth testXFTPServer2 authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH - it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right Nothing + it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation)) it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testXFTPServerTest newFileBasicAuth srv = - withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> + withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2, information = Just testServerInformation} $ \_ -> -- initially passed server is not running withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a NRMInteractive 1 srv @@ -326,6 +340,43 @@ 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", EntitlementConfig (168 * 3600))]} + withXFTPServerCfg srvCfg $ \_ -> do + filePath <- createRandomFile_ (kb 128 :: Integer) "testfile" + 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 100) + gExpires <- waitSndDone sndr + liftIO $ expiresIn gExpires nowSec (100 * 3600) + -- the same request without the credential is capped at the default maximum + withAgent 2 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB2 $ \sndr -> runRight_ $ do + xftpStartWorkers sndr (Just senderFiles) + nowSec <- liftIO $ systemSeconds <$> getSystemTime + _ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just 100) + gExpires <- waitSndDone sndr + let ExpirationConfig {ttl} = defaultFileExpiration + liftIO $ expiresIn gExpires nowSec ttl + where + expiresIn gExpires nowSec secs = case gExpires of + Just (GSTExpires t) -> do + t `shouldSatisfy` (>= nowSec + secs) + t `shouldSatisfy` (< nowSec + secs + 7200) + Nothing -> expectationFailure "expected granted storage time in SFDONE" + waitSndDone sndr = + sfGet sndr >>= \case + ("", _, A.SFDONE _ _ g) -> pure g + ("", _, SFPROG _ _) -> waitSndDone sndr + r -> error $ "Expected SFDONE, got " <> show r + testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceive rcp rfd = testReceiveCF rcp rfd Nothing @@ -619,7 +670,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 b306ae39c..772b1b692 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -19,6 +19,10 @@ 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 Simplex.FileTransfer.Types (SndFileId) +import qualified Simplex.Messaging.Agent as A +import Simplex.Messaging.Agent.Protocol (UserId) +import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server @@ -32,6 +36,9 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) #endif +xftpSendFile :: A.AgentClient -> UserId -> CryptoFile -> Int -> A.AE SndFileId +xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing + data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s) updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig @@ -181,7 +188,9 @@ testXFTPServerConfig = newFileBasicAuth = Nothing, controlPortAdminAuth = Nothing, controlPortUserAuth = Nothing, - fileExpiration = Just defaultFileExpiration, + fileExpiration = defaultFileExpiration, + fileStorageEntitlements = mempty, + entitlementKeys = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, xftpCredentials = @@ -192,6 +201,7 @@ testXFTPServerConfig = }, httpCredentials = Nothing, xftpServerVRange = supportedFileServerVRange, + information = Nothing, logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", @@ -215,7 +225,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 d3d53e6b8..e9f932170 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -22,13 +22,15 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.CaseInsensitive as CI import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock (getCurrentTime) import qualified Data.X509 as X import Data.X509.Validation (Fingerprint (..), getFingerprint) 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 +39,7 @@ 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 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 = (\(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)) @@ -240,13 +245,13 @@ 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 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 @@ -538,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) @@ -564,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 diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index 0172a6dc7..b56fbef72 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) @@ -2885,6 +2885,7 @@ webHandshakeTest cfg caFile = do \import sodium from 'libsodium-wrappers-sumo';\ \import * as Addr from './dist/protocol/address.js';\ \import * as Hs from './dist/protocol/handshake.js';\ + \import * as Tx from './dist/protocol/transmission.js';\ \import * as Id from './dist/crypto/identity.js';\ \await sodium.ready;\ \const server = Addr.parseXFTPServer('" @@ -2905,7 +2906,7 @@ webHandshakeTest cfg caFile = do \ ? Id.verifyIdentityProof({certChainDer: hs.certChainDer, signedKeyDer: hs.signedKeyDer,\ \sigBytes: hs.webIdentityProof, challenge, sessionId: hs.sessionId, keyHash: server.keyHash})\ \ : false;\ - \const ver = hs.xftpVersionRange.maxVersion;\ + \const ver = Math.min(hs.xftpVersionRange.maxVersion, Tx.currentXFTPVersion);\ \const s2 = client.request({':method': 'POST', ':path': '/', 'xftp-handshake': '1'});\ \s2.end(Buffer.from(Hs.encodeClientHandshake({xftpVersion: ver, keyHash: server.keyHash})));\ \const ack = await readBody(s2);\ @@ -3197,7 +3198,7 @@ haskellUploadTsDownloadTest cfg = do runRight_ $ xftpStartWorkers sndr (Just senderFiles) _ <- runRight $ xftpSendFile sndr 1 (CF.plain filePath) 1 sfProgress sndr 50000 - (_, _, SFDONE _ [rfd]) <- sfGet sndr + (_, _, SFDONE _ [rfd] _) <- sfGet sndr pure rfd let yamlDesc = strEncode vfd tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"