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..b3deadb90 --- /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 + { entitlementName :: Text, + expiresAt :: UTCTime, + extraInfo :: Text + } + +data EntitlementCredential = EntitlementCredential + { issuerKeyIdx :: Int, + masterKey :: MasterKey, + issuerSignature :: BBSSignature, + entitlement :: Entitlement + } + +data EntitlementProof = EntitlementProof + { issuerKeyIdx :: Int, + proof :: BBSProof, + entitlement :: Entitlement + } +``` + +Functions and constants: + +- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed +- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes +- `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` +- `verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it) +- the issuer public keys constant `Map Int BBSPublicKey` + +## 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 Int64`: `Nothing` requests the server maximum, `Just` a number of hours) to `FNEW` +- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version) + +## 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`; 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 +- verify only when the answer can change: the name is configured with a maximum above the default, and the entitlement expired less than 24 hours ago. A proof that fails these checks or fails to verify is logged, and the session gets the default maximum +- `HandshakeAccepted` holds the resolved maximum for the session, and `processXFTPRequest` takes it from there, so no proof is verified while a command is processed +- `createFile` caps the requested storage time by the session maximum + +## simplexmq: server store and expiration + +The `files` table gets a nullable `expires_at`. Every new file stores a concrete `expires_at`. It is NULL only for pre-feature rows, which the migration must not re-date (it has no access to the operator's configured TTL); those are expired at query time as `created_at + ttl`. + +Common to both stores, in `Simplex.FileTransfer.Server.Store`: + +- add `expiresAt :: Maybe RoundedFileTime` to `FileRec` +- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, cap the requested hours at the entitlement's maximum, round the expiry up to the hour, store it, and return that same value as the granted storage +- a valid proof raises the maximum to the entitlement's configured value; a proof that fails verification, carries an unknown issuer key, or whose entitlement expired more than 24 hours ago falls back to the default maximum. The entitlement is honoured for 24 hours after its `expiresAt`. +- `expiredFiles` receives `now` and `old` (= `now - ttl`). A stored expiry is deleted when `expires_at < now` (no grace — it is already rounded up); a legacy row (no `expires_at`) is deleted when `created_at + fileTimePrecision < old` (the grace covers `created_at` being floored to the hour) +- retain `created_at` for statistics, export, and the legacy fallback + +STM store: + +- in `expiredFiles`, expire a new file when `roundedSeconds expiresAt < now`, and a legacy file (no `expiresAt`) when `created_at + fileTimePrecision < old` + +PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations: + +- add the nullable column `expires_at BIGINT` (no backfill) +- add one composite index `idx_files_expiry ON files (expires_at, created_at)` +- `expiredFiles` query: `WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?` with `(now, old - fileTimePrecision)`. The first arm deletes stored (already rounded-up) expiries; the second drains legacy rows, with the grace folded into `old - fileTimePrecision` so the columns stay bare and sargable. Keep the `OR` at the top level so each disjunct is independently indexable (BitmapOr on the composite index): `expires_at` covers arm 1's range and arm 2's `IS NULL` group, and `created_at` orders arm 2 within that group. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order. + +Store log, in `Simplex.FileTransfer.Server.StoreLog`: + +- 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 Int64` hours) to `xftpSendFile` +- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and closes that user's XFTP clients, so the next upload presents the new credential + +Store, in both the SQLite and PostgreSQL agent stores: + +- add a nullable 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 reads the user's credential, looks the issuer key up, and generates the proof over the session id. A missing credential or a failure to generate gives `Nothing`, with the failure logged +- `xftpClientHandshakeV1` calls it with the session id from the connection, and sends the result in the handshake +- `agentXFTPNewChunk` reads the storage time from the send record and sends FNEW with it +- `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica` + +Completion: + +- `createXFTPChunk` returns the granted expiry as `Maybe GrantedStorageTime`; `SndFileChunkReplica` and `NewSndChunkReplica` carry `expiresAt :: Maybe GrantedStorageTime` +- persist it in a nullable `replica_expires_at` column on `snd_file_chunk_replicas` (added to the entitlement migration): `createSndFileReplica` stores `epochSeconds`, `getSndFile` reads it back into `GSTExpires` +- on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord` +- `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later) + +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 +- store log round trip in `tests/CoreTests/StoreLogTests.hs`, in the shape of the SMP store log test: a file record survives a write, a read into the store, and compaction, including a file blocked with a notice, where the record has a field after the blocking info + +## simplex-chat + +- remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI +- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent +- pass the user's credential 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/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..7ed6bdf49 --- /dev/null +++ b/rfcs/2026-08-22-xftp-file-storage-time.md @@ -0,0 +1,101 @@ +# 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 = entName entExpires entExtra +entName = shortString ; e.g. "supporter", "legend" +entExpires = shortString ; expiration as a UTCTime ISO8601 string +entExtra = shortString ; opaque, interpretation out of scope + +entitlementProof = issuerKeyIndex bbsProof entitlement +issuerKeyIndex = 2*2 OCTET ; Word16, network byte order +bbsProof = largeString ; BBS proof bytes +``` + +The presentation header that the BBS proof is generated over is not transmitted; the server takes it from the session (see [Binding](#binding)), which is what binds the proof. + +## Storage time + +``` +fileStorageTime = %s"0" / (%s"1" storageHours) +storageHours = 8*8 OCTET ; Int64, network byte order +``` + +The storage time is an optional number of hours. Absent (`%s"0"`) requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value (`%s"1"` with hours) requests a specific number of hours. + +## 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 once, when it accepts the handshake, and keeps the resulting maximum storage time for the session. A proof that fails to verify, names an entitlement the server does not configure, or names one whose expiration passed more than 24 hours ago, is logged and ignored, and the session gets the default maximum. The client learns nothing about which entitlements the server accepts. + +## Commands + +The new protocol version extends FNEW with the storage time. + +``` +fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime +``` + +`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode no `fileStorageTime`, and the server applies the default storage time. + +## Responses + +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. + +## 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..2fce56fbd 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -135,6 +135,7 @@ library Simplex.Messaging.Crypto.Lazy Simplex.Messaging.Crypto.Ratchet Simplex.Messaging.Crypto.BBS + Simplex.Messaging.Crypto.Entitlement Simplex.Messaging.Crypto.SNTRUP761 Simplex.Messaging.Crypto.SNTRUP761.Bindings Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines @@ -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..c5a92f58e 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -54,7 +54,7 @@ import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize) import Simplex.FileTransfer.Crypto import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime, SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -68,6 +68,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store.AgentStore import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.Lazy as LC @@ -350,8 +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 Int64 -> AM SndFileId +xftpSendFile' c userId file numRecipients storageTime = 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 storageTime 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, storageTime} <- 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' storageTime let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -454,8 +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 Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk numRecipients' storageTime 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 storageTime 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 = fmap minimum . mapM chunkExpiresAt + where + chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas) createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient] createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks where diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index a5cd4acfe..b03881844 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -36,6 +36,7 @@ import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad import Control.Monad.Except +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.Bifunctor (first) @@ -57,6 +58,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 +86,7 @@ import Simplex.Messaging.Protocol SenderId, pattern NoEntity, ) -import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) +import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), SessionId, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client @@ -126,8 +128,8 @@ defaultXFTPClientConfig = clientALPN = Just alpnSupportedXFTPhandshakes } -getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) -getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do +getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (SessionId -> IO (Maybe EntitlementProof)) -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) +getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs mkEntitlementProof disconnected = runExceptT $ do let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession ProtocolServer _ host port keyHash = srv useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN @@ -146,19 +148,20 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, thParams@THandleParams {thVersion} <- case sessionALPN of Just alpn | alpn == xftpALPNv1 || alpn == httpALPN11 -> - xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0 + xftpClientHandshakeV1 serverVRange keyHash http2Client mkEntitlementProof thParams0 _ -> pure thParams0 logDebug $ "Client negotiated protocol: " <> tshow thVersion let c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c pure c -xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient) -xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do +xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> (SessionId -> IO (Maybe EntitlementProof)) -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient) +xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} mkEntitlementProof thParams0 = do shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake (vr, sk) <- processServerHandshake shs let v = maxVersion vr - sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash} + ep <- if v >= fileStorageTimeXFTPVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing + sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof = ep} let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing} pure thParams0 {thAuth, thVersion = v, thServerVRange = vr} where @@ -253,10 +256,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 Int64 -> + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) +createXFTPChunk c spKey file rcps auth_ storageTime = + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime) Nothing >>= \case + (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..84a256f83 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 Int64 -> 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..8b2d38c1c 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -30,11 +30,13 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map.Strict as M import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) +import Data.Time.Clock (UTCTime (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay) +import Data.Time.Clock.System (systemSeconds, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) import qualified Data.X509 as X @@ -54,6 +56,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 (..), verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -66,7 +70,7 @@ import Simplex.Messaging.Server.Stats import Simplex.Messaging.SystemTime import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS) +import Simplex.Messaging.Transport (CertChainPubKey (..), EntitlementConfig (..), SessionEntitlement (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize) @@ -125,12 +129,12 @@ data Handshake xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do - mapM_ (expireServerFiles Nothing) fileExpiration + expireServerFiles Nothing fileExpiration restoreServerStats raceAny_ ( runServer - : expireFilesThread_ cfg - <> serverStatsThread_ cfg + : expireFiles fileExpiration + : serverStatsThread_ cfg <> prometheusMetricsThread_ cfg <> controlPortThread_ cfg ) @@ -212,12 +216,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira processClientHandshake pk = do unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE body <- liftHS $ C.unPad bodyHead - XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body + XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body kh <- asks serverIdentity unless (keyHash == kh) $ throwE HANDSHAKE case compatibleVRange' xftpServerVRange v of Just (Compatible vr) -> do - let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing} + ent <- lift $ verifiedEntitlement entitlementProof + let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing} thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr} atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions #ifdef slow_servers @@ -226,6 +231,19 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS) pure Nothing Nothing -> throwE HANDSHAKE + verifiedEntitlement :: Maybe EntitlementProof -> M s (Maybe SessionEntitlement) + verifiedEntitlement ep = + pure ep $>>= \proof@EntitlementProof {entitlement = Entitlement {entitlementName, expiresAt = expiresAtTs}} -> do + entCfg <- asks $ M.lookup entitlementName . fileStorageEntitlements . config + now <- liftIO getSystemSeconds + let expiresAt = RoundedSystemTime $ systemSeconds $ utcToSystemTime expiresAtTs + case entCfg of + Just cfg | entitlementValid now expiresAt -> do + keys <- asks $ entitlementKeys . config + liftIO (verifyEntitlement keys (BBSPresHeader sessionId) proof) >>= \case + Just True -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg} + r -> Nothing <$ logError ("entitlement not verified: " <> tshow r) + _ -> pure Nothing sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer)) sendError err = do runExceptT (encodeXftp err) >>= \case @@ -243,10 +261,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 +416,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 +458,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = case cmd of - FileCmd SFSender (FNEW file rcps auth') -> 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 +479,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH -processXFTPRequest :: forall s. FileStoreClass s => 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 storageTime -> noFile =<< ifM allowNew (createFile file rks storageTime) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -483,29 +498,39 @@ 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 Int64 -> M s FileResponse + createFile file rks storageTime = do st <- asks fileStore r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE ts <- liftIO getFileTime + now <- liftIO getSystemSeconds + maxSeconds <- lift $ storageMaxSeconds now + let secs = maybe maxSeconds (min maxSeconds . (* 3600)) storageTime + fileExpiresAt = RoundedSystemTime $ ((roundedSeconds now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts + 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,6 +665,9 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1) liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo) +entitlementValid :: SystemSeconds -> SystemSeconds -> Bool +entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now + getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime @@ -648,16 +676,17 @@ expireServerFiles itemDelay expCfg = do st <- asks fileStore us <- asks usedStorage usedStart <- readTVarIO us + now <- liftIO $ roundedSeconds <$> getSystemSeconds old <- liftIO $ expireBeforeEpoch expCfg filesCount <- liftIO $ getFileCount st logNote $ "Expiration check: " <> tshow filesCount <> " files" - expireLoop st us 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 +699,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..ff23c8402 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -37,12 +37,17 @@ 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 import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) +import Simplex.Messaging.Crypto.BBS (BBSPublicKey) +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) @@ -64,6 +69,7 @@ import Simplex.FileTransfer.Transport (VersionRangeXFTP) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential) import Simplex.Messaging.Util (tshow) import System.IO (IOMode (..)) @@ -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 @@ -171,7 +180,11 @@ 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 + unless (all ((>= defaultMax) . storageTime) (M.elems fileStorageEntitlements)) $ do + logError "STORE: entitlement storage time is below the default file expiration" + exitFailure random <- C.newRandom (store, storeLog) <- case serverStoreCfg of XSCMemory storeLogPath -> do @@ -196,7 +209,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 Int64) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 070dc546f..51d692dd5 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Simplex.FileTransfer.Server.Main @@ -16,11 +17,13 @@ module Simplex.FileTransfer.Server.Main import Control.Monad (unless, when) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Ini (lookupValue, readIniFile) +import Data.Ini (Ini, lookupValue, readIniFile) import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.List (find) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -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) @@ -239,9 +244,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do putStrLn $ case storeLogFile of Just f -> "Store log: " <> f _ -> "Store log disabled." - putStrLn $ case fileExpiration of - Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl - _ -> "not expiring files" + putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration) putStrLn $ case inactiveClientExpiration of Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" _ -> "not expiring inactive clients" @@ -287,10 +290,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 @@ -437,3 +441,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..1bbfaf07f 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 -> Int64 -> 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 < 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..887ea23ed 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -82,17 +82,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 +131,13 @@ instance FileStoreClass PostgresFileStore where getFile st party fId = runExceptT $ case party of SFSender -> do - row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, 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 +152,12 @@ instance FileStoreClass PostgresFileStore where DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId) withLog "ackFile" st $ \s -> logAckFile s rId - expiredFiles st 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 < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?" + (now, old - fileTimePrecision, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) @@ -174,21 +174,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 +243,7 @@ importFileStore storeLogFilePath dbCfg = do fCnt <- withTransaction (dbStore pgStore) $ \db -> do DB.copy_ db - "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, 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 +282,13 @@ exportFileStore storeLogFilePath dbCfg = do !fCnt <- withTransaction (dbStore pgStore) $ \db -> DB.fold_ db - "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, 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 +326,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m () iforM_ xs f = zipWithM_ f [0 ..] xs fileRecToCSV :: SenderId -> FileRec -> IO ByteString -fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, 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 +338,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..c6f792943 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 sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status 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..9742430f3 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,7 @@ module Simplex.FileTransfer.Transport ) where -import Control.Applicative (optional) +import Control.Applicative (optional, (<|>)) import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad @@ -56,6 +57,7 @@ import Data.Word (Word16, Word32) import Network.HTTP2.Client (HTTP2Error) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers @@ -97,8 +99,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 @@ -131,7 +136,9 @@ data XFTPClientHandshake = XFTPClientHandshake { -- | agreed XFTP server protocol version xftpVersion :: VersionXFTP, -- | server identity - CA certificate fingerprint - keyHash :: C.KeyHash + keyHash :: C.KeyHash, + -- | proof of the user entitlement bound to the session + entitlementProof :: Maybe EntitlementProof } instance Encoding XFTPClientHello where @@ -143,12 +150,13 @@ instance Encoding XFTPClientHello where pure XFTPClientHello {webChallenge} instance Encoding XFTPClientHandshake where - smpEncode XFTPClientHandshake {xftpVersion, keyHash} = - smpEncode (xftpVersion, keyHash) + smpEncode XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} = + smpEncode (xftpVersion, keyHash, entitlementProof) smpP = do (xftpVersion, keyHash) <- smpP + entitlementProof <- smpP <|> pure Nothing Tail _compat <- smpP - pure XFTPClientHandshake {xftpVersion, keyHash} + pure XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} instance Encoding XFTPServerHandshake where smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} = diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ff70b8f13..d772e46d5 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -29,16 +29,20 @@ module Simplex.FileTransfer.Types sndChunkSize, ) where +import qualified Data.Aeson as JD import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word32) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (GrantedStorageTime (..)) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -167,7 +171,8 @@ data SndFile = SndFile prefixPath :: Maybe FilePath, status :: SndFileStatus, deleted :: Bool, - redirect :: Maybe RedirectFileInfo + redirect :: Maybe RedirectFileInfo, + storageTime :: Maybe Int64 } deriving (Show) @@ -187,6 +192,10 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode instance ToField SndFileStatus where toField = toField . textEncode +instance ToField EntitlementCredential where toField = toField . decodeUtf8 . LB.toStrict . JD.encode + +instance FromField EntitlementCredential where fromField = fromTextField_ (JD.decode . LB.fromStrict . encodeUtf8) + instance TextEncoding SndFileStatus where textDecode = \case "new" -> Just SFSNew @@ -225,7 +234,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 +247,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 979704fd3..3522596d2 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -108,6 +108,7 @@ module Simplex.Messaging.Agent getConnectionServers, getConnectionRatchetAdHash, setProtocolServers, + setUserEntitlement, checkUserServers, testProtocolServer, setNtfServers, @@ -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 @@ -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 Int64 -> AE SndFileId +xftpSendFile c = withAgentEnv c .:: xftpSendFile' c {-# INLINE xftpSendFile #-} -- | Send XFTP file @@ -3049,6 +3051,13 @@ setProtocolServers c userId srvs = do checkUserServers "setProtocolServers" srvs atomically $ TM.insert userId (mkUserServers srvs) (userServers c) +-- | Change the entitlement credential presented to XFTP servers for the user. +-- The credential is presented in the handshake, so the user's XFTP clients are closed to present the new one. +setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO () +setUserEntitlement c userId cred_ = do + atomically $ maybe (TM.delete userId) (TM.insert userId) cred_ $ userEntitlements c + closeUserXFTPClients c userId + checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO () checkUserServers name srvs = unless (any (\ServerCfg {enabled} -> enabled) srvs) $ diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 45e7695b8..5bcdf8a54 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Client reconnectServerClients, reconnectSMPServer, closeXFTPServerClient, + closeUserXFTPClients, runSMPServerTest, runXFTPServerTest, runNTFServerTest, @@ -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,22 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, connectClient :: XFTPClientVar -> AM XFTPClient connectClient v = do cfg <- asks $ xftpCfg . config + keys <- asks $ entitlementKeys . config xftpNetworkConfig <- getNetworkConfig c ts <- readTVarIO proxySessTs liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $ - X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $ + X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (mkEntitlementProof keys) $ clientDisconnected v + mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof) + mkEntitlementProof keys sessId = + TM.lookupIO userId userEntitlements + $>>= \cred -> pure (M.lookup (issuerKeyIdx cred) keys) + $>>= \pk -> generateEntitlementProof pk cred (BBSPresHeader sessId) + >>= \case + Right p -> pure $ Just p + Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e) + clientDisconnected :: XFTPClientVar -> XFTPClient -> IO () clientDisconnected v client = do atomically $ removeSessVar v tSess xftpClients @@ -1037,6 +1053,15 @@ reconnectSMPServer c userId srv = do | userId == userId' && srv == srv' = (v :) | otherwise = id +closeUserXFTPClients :: AgentClient -> UserId -> IO () +closeUserXFTPClients c userId = do + cs <- readTVarIO $ xftpClients c + mapM_ (forkIO . closeClient_ c) $ M.foldrWithKey userClient [] cs + where + userClient (userId', _, _) v + | userId == userId' = (v :) + | otherwise = id + closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () closeClient c clientSel tSess = atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c) @@ -1337,7 +1362,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s liftIO $ do let tSess = (userId, srv, Nothing) ts <- readTVarIO $ proxySessTs c - X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure ()) >>= \case + X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case Right xftp -> withTestChunk filePath $ do (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -1345,7 +1370,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize} r <- runExceptT $ do - (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth + (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 @@ -2186,16 +2211,17 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se g <- asks random withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec -agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Int64 -> AM NewSndChunkReplica +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageTime = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (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 storageTime 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..b472cb5b7 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -309,8 +309,9 @@ import Network.Socket (ServiceName) import qualified Network.TLS as TLS import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..), SFileParty (..)) import Simplex.FileTransfer.Types +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) import Simplex.Messaging.Agent.Stats @@ -3424,13 +3425,13 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) -createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Int64 -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageTime = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) 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_, storageTime)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3466,7 +3467,7 @@ getSndFile db sndFileId = runExceptT $ do DB.query db ( [sql| - SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest + SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, storage_time FROM snd_files WHERE snd_file_id = ? |] @@ -3476,12 +3477,12 @@ getSndFile db sndFileId = runExceptT $ do ) (Only sndFileId) where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) = + toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe Int64) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageTime)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageTime, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- @@ -3510,7 +3511,7 @@ getSndFile db sndFileId = runExceptT $ do db [sql| SELECT - r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, + r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at, s.xftp_host, s.xftp_port, s.xftp_key_hash FROM snd_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id @@ -3521,10 +3522,10 @@ getSndFile db sndFileId = runExceptT $ do rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId pure (replica :: SndFileChunkReplica) {rcvIdsKeys} where - toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica - toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica + toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec, host, port, keyHash) = let server = XFTPServer host port keyHash - in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} + in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []} getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] getChunkReplicaRecipients_ db replicaId = @@ -3605,16 +3606,16 @@ createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> I createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO () -createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do +createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys, expiresAt} = do srvId <- createXFTPServer_ db server DB.execute db [sql| INSERT INTO snd_file_chunk_replicas - (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status) - VALUES (?,?,?,?,?,?) + (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status, replica_expires_at) + VALUES (?,?,?,?,?,?,?) |] - (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated) + (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated, epochSeconds <$> expiresAt) rId <- insertedRowId db forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do DB.execute @@ -3687,7 +3688,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do chunkSpec, digest, filePrefixPath, - replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}] + replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = Nothing, rcvIdsKeys = []}] } updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO () diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/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..101a0f3d4 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql @@ -741,7 +741,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..45c83e6f1 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -33,6 +33,7 @@ import Data.Proxy (Proxy (..)) import Foreign import Foreign.C import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) +import Simplex.Messaging.Encoding (Encoding (..), Large (..)) import Simplex.Messaging.Encoding.String import System.IO.Unsafe (unsafePerformIO) @@ -106,6 +107,10 @@ instance StrEncoding BBSProof where then pure (BBSProof bs) else fail $ "BBS: invalid proof length " <> show len +instance Encoding BBSProof where + smpEncode (BBSProof p) = smpEncode (Large p) + smpP = BBSProof . unLarge <$> smpP + -- FFI data BBS_Ciphersuite diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs new file mode 100644 index 000000000..049954b10 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Messaging.Crypto.Entitlement + ( Entitlement (..), + EntitlementCredential (..), + EntitlementProof (..), + MasterKey (..), + entitlementBBSHeader, + entitlementIssuerKeys, + signEntitlement, + verifyCredential, + generateEntitlementProof, + verifyEntitlement, + ) +where + +import Control.Monad (forM) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson.TH as JQ +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Either (fromRight) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime) +import Data.Word (Word16) +import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON) +import Simplex.Messaging.Util ((<$$>)) + +newtype MasterKey = MasterKey ByteString + deriving newtype (Eq, Show, StrEncoding) + deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey) + +data Entitlement = Entitlement + { entitlementName :: Text, + expiresAt :: UTCTime, + 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) + +instance Encoding Entitlement where + smpEncode Entitlement {entitlementName, expiresAt, extraInfo} = + smpEncode (entitlementName, strEncode expiresAt, extraInfo) + smpP = do + (entitlementName, expBs, extraInfo) <- smpP + expiresAt <- either fail pure $ strDecode (expBs :: ByteString) + pure Entitlement {entitlementName, expiresAt, 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 {entitlementName, expiresAt, extraInfo} = + [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] + +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 :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof) +generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph = + EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement) + +verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool) +verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} = + forM (M.lookup issuerKeyIdx keys) $ \pk -> + 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 fbab1b01c..16ad58ab3 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -2132,7 +2132,7 @@ client t' <- case tParse clntTHParams b of t :| [] -> pure $ tDecodeServer clntTHParams t _ -> throwE BLOCK - let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, sessSecret' = Just clientSecret} + let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, peerEntitlement = Nothing, sessSecret' = Just clientSecret} encodeResp r = do r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 9c9392c21..a366e79f7 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -84,6 +84,8 @@ module Simplex.Messaging.Transport THandle (..), THandleParams (..), THandleAuth (..), + SessionEntitlement (..), + EntitlementConfig (..), CertChainPubKey (..), ServiceCredentials (..), THClientService' (..), @@ -119,6 +121,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Default (def) import Data.Functor (($>)) +import Data.Int (Int64) import Data.Kind (Type) import Data.Tuple (swap) import Data.Typeable (Typeable) @@ -136,6 +139,7 @@ import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON) import Simplex.Messaging.Server.Information +import Simplex.Messaging.SystemTime (SystemSeconds) import Simplex.Messaging.Transport.Buffer import Simplex.Messaging.Transport.Shared import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>)) @@ -483,10 +487,15 @@ data THandleAuth (p :: TransportPeer) where THAuthServer :: { serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key peerClientService :: Maybe THPeerClientService, + peerEntitlement :: Maybe SessionEntitlement, -- verified in the handshake, applies to the whole session sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only) } -> THandleAuth 'TServer +data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig} + +newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64} + type THClientService = THClientService' C.PrivateKeyEd25519 type THPeerClientService = THClientService' C.PublicKeyEd25519 @@ -801,7 +810,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer) smpTHandleServer th v vr pk k_ proxyServer peerClientService = do - let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_} + let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, peerEntitlement = Nothing, sessSecret' = (`C.dh'` pk) <$!> k_} be <- blockEncryption th proxyServer thAuth pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 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..635b4ebf6 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -13,7 +13,10 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isLeft, isRight) import Data.Int (Int64) +import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE @@ -25,6 +28,7 @@ import qualified SMPClient import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Crypto.Entitlement import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode) @@ -119,6 +123,8 @@ cryptoTests = do it "should produce unlinkable proofs" testBBSUnlinkable it "should produce proof of expected size" testBBSProofSize it "should roundtrip JSON and reject wrong-length input" testBBSJSON + describe "Entitlement" $ do + it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip instance Eq C.APublicKey where C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of @@ -444,3 +450,21 @@ testBBSJSON = do -- FromJSON must reject wrong-length input (regression: StrJSON length validation) (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing + +testEntitlementRoundtrip :: IO () +testEntitlementRoundtrip = do + Right (pk, sk) <- bbsKeyGen + let keys = M.singleton 1 pk + mk = MasterKey (B.replicate 32 '\7') + ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""} + ph = BBSPresHeader "session-id + snd-key + digest" + Right cred <- signEntitlement sk 1 mk ent + verifyCredential pk cred `shouldReturn` True + Right proof <- generateEntitlementProof pk cred ph + verifyEntitlement keys ph proof `shouldReturn` Just True + -- a different presentation header does not verify (session/chunk binding) + verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` Just False + -- an unknown issuer key index yields Nothing + verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` Nothing + -- the protocol encoding of the proof roundtrips + smpDecode (smpEncode proof) `shouldBe` Right proof diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 01966ba05..1b59430a3 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -20,9 +20,13 @@ import qualified Data.Map.Strict as M import qualified Data.X509 as X import qualified Data.X509.Validation as XV import SMPClient +import Simplex.FileTransfer.Protocol (FileInfo (..)) +import Simplex.FileTransfer.Server.Store (FileRec (..), FileRecipient (..), FileStoreClass (..), RoundedFileTime, STMFileStore (..)) +import Simplex.FileTransfer.Server.StoreLog (FileStoreLogRecord (..), readWriteFileStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol +import Simplex.Messaging.Protocol.Types (ClientNotice (..)) import Simplex.Messaging.Server.Env.STM (readWriteQueueStore) import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.Types @@ -191,3 +195,75 @@ testSMPStoreLog testSuite tests = compacted' `shouldBe` compacted storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec) storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec)) + +type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) + +type XFTPStoreLogTestCase = StoreLogTestCase FileStoreLogRecord (M.Map SenderId FileRecState) + +deriving instance Eq FileInfo + +deriving instance Eq FileRecipient + +deriving instance Eq FileStoreLogRecord + +testFileStoreLogFile :: FilePath +testFileStoreLogFile = "tests/tmp/xftp-server-store.log" + +fileStoreLogTests :: Spec +fileStoreLogTests = do + g <- runIO C.newRandom + (sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g + sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g + let file = FileInfo {sndKey, size = 16384, digest = "12345678"} + createdAt = RoundedSystemTime 1600000000 + expiresAt = RoundedSystemTime 1600172800 + blocked = BlockingInfo {reason = BRSpam, notice = Nothing} + blockedWithNotice = BlockingInfo {reason = BRContent, notice = Just ClientNotice {ttl = Just 86400}} + testXFTPStoreLog + "XFTP server store log" + [ SLTC + { name = "create file", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive], + compacted = [AddFile sId file createdAt (Just expiresAt) EntityActive], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityActive))] + }, + SLTC + { name = "create file without expiration", + saved = [AddFile sId file createdAt Nothing EntityActive], + compacted = [AddFile sId file createdAt Nothing EntityActive], + state = M.fromList [(sId, (file, createdAt, Nothing, EntityActive))] + }, + SLTC + { name = "create and block file", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blocked], + compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blocked)], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blocked))] + }, + SLTC + { name = "create and block file with notice", + saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice], + compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)], + state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))] + } + ] + +testXFTPStoreLog :: String -> [XFTPStoreLogTestCase] -> Spec +testXFTPStoreLog testSuite tests = + describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do + l <- openWriteStoreLog False testFileStoreLogFile + mapM_ (writeStoreLogRecord l) saved + closeStoreLog l + replicateM_ 3 $ testReadWrite t + where + testReadWrite SLTC {compacted, state} = do + st <- newFileStore () :: IO STMFileStore + l <- readWriteFileStore testFileStoreLogFile st + storeState st `shouldReturn` state + closeStoreLog l + ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile + compacted' `shouldBe` compacted + storeState :: STMFileStore -> IO (M.Map SenderId FileRecState) + storeState st = readTVarIO (files st) >>= mapM fileState + fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do + status <- readTVarIO fileStatus + pure (fileInfo, createdAt, expiresAt, status) diff --git a/tests/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index 20c0e77fc..87afb8e68 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -75,7 +75,7 @@ testAddGetFileSender = withPgStore $ \st -> do g <- C.newRandom (sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sk - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () result <- getFile st SFSender testSenderId case result of Right (FileRec {senderId, fileInfo = fi, createdAt}, key) -> do @@ -92,7 +92,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () result <- getFile st SFRecipient testRecipientId case result of @@ -106,8 +106,8 @@ testDuplicateFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Left DUPLICATE_ + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_ testGetNonexistent :: Expectation testGetNonexistent = withPgStore $ \st -> do @@ -119,7 +119,7 @@ testSetFilePath = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () setFilePath st testSenderId "/tmp/test_file" `shouldReturn` Right () -- Second setFilePath should fail (file_path IS NULL guard) setFilePath st testSenderId "/tmp/other_file" `shouldReturn` Left AUTH @@ -135,7 +135,7 @@ testDuplicateRecipient = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_ @@ -145,7 +145,7 @@ testDeleteFileCascade = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () deleteFile st testSenderId `shouldReturn` Right () -- File and recipient should both be gone @@ -157,7 +157,7 @@ testBlockFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () let blockInfo = BlockingInfo {reason = BRContent, notice = Nothing} blockFile st testSenderId blockInfo False `shouldReturn` Right () result <- getFile st SFSender testSenderId @@ -171,7 +171,7 @@ testAckFile = withPgStore $ \st -> do (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let fileInfo = testFileInfo sndKey - addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right () + addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () ackFile st testRecipientId `shouldReturn` Right () -- Recipient gone, but file still exists @@ -189,11 +189,11 @@ testExpiredFiles = withPgStore $ \st -> do oldTime = RoundedSystemTime 100000 newTime = RoundedSystemTime 999999999 -- Add old and new files - addFile st (EntityId "old_file________") fileInfo oldTime EntityActive `shouldReturn` Right () + addFile st (EntityId "old_file________") fileInfo oldTime Nothing EntityActive `shouldReturn` Right () void $ setFilePath st (EntityId "old_file________") "/tmp/old" - addFile st (EntityId "new_file________") fileInfo newTime EntityActive `shouldReturn` Right () + addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right () -- Query expired with cutoff that only catches old file - expired <- expiredFiles st 500000 100 + expired <- expiredFiles st 500000 500000 100 length expired `shouldBe` 1 case expired of [(sId, path, sz)] -> do @@ -222,8 +222,8 @@ testStorageAndCountForStore st = do fileInfoB = fileInfoA {size = 64000} fileA = EntityId "file_a__________" fileB = EntityId "file_b__________" - addFile st fileA fileInfoA testCreatedAt EntityActive `shouldReturn` Right () - addFile st fileB fileInfoB testCreatedAt EntityActive `shouldReturn` Right () + addFile st fileA fileInfoA testCreatedAt Nothing EntityActive `shouldReturn` Right () + addFile st fileB fileInfoB testCreatedAt Nothing EntityActive `shouldReturn` Right () getFileCount st `shouldReturn` 2 getUsedStorage st `shouldReturn` 0 setFilePath st fileA "/tmp/file_a" `shouldReturn` Right () @@ -248,11 +248,11 @@ testMigrationRoundTrip = do sId1 = EntityId "migration_file_1" sId2 = EntityId "migration_file_2" rId1 = EntityId "migration_rcp_1_" - addFile stmStore sId1 fileInfo1 testCreatedAt EntityActive `shouldReturn` Right () + addFile stmStore sId1 fileInfo1 testCreatedAt Nothing EntityActive `shouldReturn` Right () void $ setFilePath stmStore sId1 "/tmp/file1" addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right () let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing} - addFile stmStore sId2 fileInfo2 testCreatedAt (EntityBlocked testBlockInfo) `shouldReturn` Right () + addFile stmStore sId2 fileInfo2 testCreatedAt Nothing (EntityBlocked testBlockInfo) `shouldReturn` Right () -- 2. Write to StoreLog sl <- openWriteStoreLog False storeLogPath writeFileStore sl stmStore 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..77229a28f 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -97,6 +97,7 @@ main = do #else describe "Store log tests" storeLogTests #endif + describe "XFTP store log tests" fileStoreLogTests describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests describe "Names resolver tests" smpNamesTests diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 34da3d125..a26787d01 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -20,27 +21,36 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Int (Int64) import Data.List (find, isSuffixOf) +import qualified Data.Map.Strict as M import Data.Maybe (fromJust) +import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay) +import Data.Time.Clock.System (getSystemTime, systemSeconds) import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3) import SMPClient (xit'') import Simplex.FileTransfer.Client (XFTPClientConfig (..)) import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription) -import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..)) import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..)) import Simplex.FileTransfer.Server.Store (STMFileStore) import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH)) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) -import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, 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.Transport (EntitlementConfig (..)) import Simplex.Messaging.Server.Information (ServerPublicInfo) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) @@ -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 @@ -326,6 +340,33 @@ 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 $ case gExpires of + Just (GSTExpires t) -> do + t `shouldSatisfy` (>= nowSec + 100 * 3600) + t `shouldSatisfy` (< nowSec + 100 * 3600 + 7200) + Nothing -> expectationFailure "expected granted storage time in SFDONE" + where + waitSndDone sndr = + sfGet sndr >>= \case + ("", _, A.SFDONE _ _ g) -> pure g + _ -> waitSndDone sndr + testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceive rcp rfd = testReceiveCF rcp rfd Nothing @@ -619,7 +660,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..203c8d826 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -19,6 +19,7 @@ import Simplex.FileTransfer.Server (runXFTPServerBlocking) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), AFStoreType (..), defaultFileExpiration, defaultInactiveClientExpiration) import Simplex.FileTransfer.Server.Store (FileStoreClass, SFSType (..), STMFileStore) import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange) +import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server @@ -32,6 +33,8 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) #endif +xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing + data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s) updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig @@ -181,7 +184,9 @@ testXFTPServerConfig = newFileBasicAuth = Nothing, controlPortAdminAuth = Nothing, controlPortUserAuth = Nothing, - fileExpiration = Just defaultFileExpiration, + fileExpiration = defaultFileExpiration, + fileStorageEntitlements = mempty, + entitlementKeys = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, xftpCredentials = @@ -215,7 +220,7 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClientWith cfg client = do ts <- getCurrentTime - getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case + getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case Right c -> client c Left e -> error $ show e diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index d3d53e6b8..f0682e83b 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -28,7 +28,8 @@ import Data.X509.Validation (Fingerprint (..), getFingerprint) import Network.HPACK.Token (tokenKey) import qualified Network.HTTP2.Client as H2 import ServerTests (logSize) -import Simplex.FileTransfer.Client +import Simplex.FileTransfer.Client hiding (createXFTPChunk) +import qualified Simplex.FileTransfer.Client as A import Simplex.FileTransfer.Description (kb) import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId, xftpBlockSize) import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..)) @@ -37,7 +38,8 @@ import Simplex.Messaging.Client (ProtocolClientError (..)) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding (smpDecode, smpEncode) -import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity) +import Data.List.NonEmpty (NonEmpty) +import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), RecipientId, SenderId, pattern NoEntity) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Transport (CertChainPubKey (..), TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS) import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient) @@ -100,6 +102,9 @@ createTestChunk fp = do B.writeFile fp bytes pure bytes +createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) +createXFTPChunk c spKey file rcps auth = (\(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..230151155 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -46,10 +46,11 @@ 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.Protocol (AEvent (..)) +import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers) +import Simplex.Messaging.Agent.Protocol hiding (SFDONE) +import qualified Simplex.Messaging.Agent.Protocol as A import SMPAgentClient (agentCfg, initAgentServers, testDB) import XFTPCLI (recipientFiles, senderFiles, testBracket) import qualified Simplex.Messaging.Crypto.File as CF @@ -168,6 +169,9 @@ impAddr = "import * as Addr from './dist/protocol/address.js';" jsOut :: String -> String jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));" +pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile +pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _ + xftpWebTests :: IO () -> Spec xftpWebTests dbCleanup = do xftpWebSourceHygieneTests