mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-16 06:12:58 +00:00
Merge remote-tracking branch 'origin/master' into ab/snrc-resolver-SMP-NAVL
This commit is contained in:
Alain Brenzikofer
@@ -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)
|
||||
|
||||
@@ -0,0 +1,168 @@
|
||||
# Implementation plan: XFTP variable file storage time
|
||||
|
||||
Proposal: `../rfcs/2026-08-22-xftp-file-storage-time.md`.
|
||||
|
||||
## simplexmq: entitlement crypto
|
||||
|
||||
New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypto.BBS`:
|
||||
|
||||
Types:
|
||||
|
||||
```
|
||||
newtype MasterKey = MasterKey ByteString
|
||||
|
||||
data Entitlement = Entitlement
|
||||
{ expiresAt :: UTCTime,
|
||||
entitlementName :: Text,
|
||||
extraInfo :: Text
|
||||
}
|
||||
|
||||
data EntitlementCredential = EntitlementCredential
|
||||
{ issuerKeyIdx :: Word16,
|
||||
masterKey :: MasterKey,
|
||||
entitlement :: Entitlement,
|
||||
issuerSignature :: BBSSignature
|
||||
}
|
||||
|
||||
data EntitlementProof = EntitlementProof
|
||||
{ issuerKeyIdx :: Word16,
|
||||
entitlement :: Entitlement,
|
||||
entProof :: BBSProof
|
||||
}
|
||||
```
|
||||
|
||||
Functions and constants:
|
||||
|
||||
- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed. The protocol encoding of `Entitlement` and its field order follow the same order
|
||||
- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes
|
||||
- `generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` (the issuer key is looked up by the credential's index; an absent index is `Left`)
|
||||
- `verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification`, where `data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it)
|
||||
- the issuer public keys constant `Map Word16 BBSPublicKey`
|
||||
|
||||
## simplexmq: protocol, new XFTP version
|
||||
|
||||
In `Simplex.FileTransfer.Transport`:
|
||||
|
||||
- add the next `VersionXFTP` and set `currentXFTPVersion` to 4
|
||||
- add `entitlementProof :: Maybe EntitlementProof` to `XFTPClientHandshake`, encoded before the `Tail` and only from this version
|
||||
- the presentation header is the session id alone
|
||||
|
||||
In `Simplex.FileTransfer.Protocol`:
|
||||
|
||||
- add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants:
|
||||
|
||||
```
|
||||
data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
|
||||
```
|
||||
|
||||
- add the storage time (`Maybe Word32`: `Nothing` and `Just 0` request the server maximum, a value above zero requests that number of hours) to `FNEW`
|
||||
- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version)
|
||||
|
||||
## simplexmq: server configuration
|
||||
|
||||
In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
|
||||
|
||||
- make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds
|
||||
- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`, into `fileStorageEntitlements :: Map Text EntitlementConfig`, where `newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64}` holds seconds; an absent key is skipped (that name gets the default), a present but malformed value fails startup
|
||||
- exit at startup if any name's maximum is below the default file expiration
|
||||
- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); the handshake verifies the proof against it, so the trusted keys never come from the sender
|
||||
|
||||
## simplexmq: server session
|
||||
|
||||
In `Simplex.FileTransfer.Server`:
|
||||
|
||||
- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. `HandshakeSent` carries `EntitlementChecked`, so the first handshake verifies and every later one on that connection reuses the result, including after `processHello` returns the session to `HandshakeSent`
|
||||
- verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum
|
||||
- a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed
|
||||
- `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise
|
||||
|
||||
## simplexmq: server store and expiration
|
||||
|
||||
The `files` table gets a nullable `expires_at`. Every new file stores a concrete `expires_at`. It is NULL only for pre-feature rows, which the migration must not re-date (it has no access to the operator's configured TTL); those are expired at query time as `created_at + ttl`.
|
||||
|
||||
Common to both stores, in `Simplex.FileTransfer.Server.Store`:
|
||||
|
||||
- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`
|
||||
- in `createFile`, cap the requested hours at the session maximum, round the expiry up to the hour, store it, and return that same value as the granted storage
|
||||
- `expiredFiles` receives `now` and `old` (= `now - ttl`). A stored expiry is deleted when `expires_at < now` (no grace — it is already rounded up); a legacy row (no `expires_at`) is deleted when `created_at + fileTimePrecision < old` (the grace covers `created_at` being floored to the hour)
|
||||
- retain `created_at` for statistics, export, and the legacy fallback
|
||||
|
||||
STM store:
|
||||
|
||||
- in `expiredFiles`, expire a new file when `roundedSeconds expiresAt < now`, and a legacy file (no `expiresAt`) when `created_at + fileTimePrecision < old`
|
||||
|
||||
PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations:
|
||||
|
||||
- add the nullable column `expires_at BIGINT` (no backfill)
|
||||
- add one composite index `idx_files_expiry ON files (expires_at, created_at)`
|
||||
- `expiredFiles` query: `(SELECT ... WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT ... WHERE expires_at IS NULL AND created_at < ? LIMIT ?)` with `(now, limit, old - fileTimePrecision, limit)`. The first arm deletes stored (already rounded-up) expiries; the second drains legacy rows, with the grace folded into `old - fileTimePrecision` so the columns stay bare and sargable. Each arm is one range over the composite index and stops at its own limit; a single `OR` predicate builds a bitmap of every match before the limit applies. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order. New files always store an expiry, so the second arm drains permanently once the legacy rows expire, and is then removed.
|
||||
|
||||
Store log, in `Simplex.FileTransfer.Server.StoreLog`:
|
||||
|
||||
- add the optional expiration to the `AddFile` record; a record without it parses to `Nothing` (the configured default), never a hardcoded value
|
||||
|
||||
## simplexmq: agent
|
||||
|
||||
The credential belongs to the user, so the agent holds it the way it holds the user's servers: in memory, supplied when the agent is created and replaced through an API. It is not stored by the agent.
|
||||
|
||||
Per-user state in `Simplex.Messaging.Agent.Env.SQLite` and `Simplex.Messaging.Agent.Client`:
|
||||
|
||||
- add `entitlements :: Map UserId EntitlementCredential` to `InitialAgentServers`, beside the servers
|
||||
- add `userEntitlements :: TMap UserId EntitlementCredential` to `AgentClient`, filled from it by `newAgentClient`
|
||||
- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant), for the issuer key that proof generation needs
|
||||
|
||||
Public API in `Simplex.Messaging.Agent`:
|
||||
|
||||
- add storage time (`Maybe Word32` hours) to `xftpSendFile`
|
||||
- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and when the credential changed it closes that user's XFTP clients, so the next upload presents the new credential
|
||||
|
||||
Store, in both the SQLite and PostgreSQL agent stores:
|
||||
|
||||
- add a nullable storage time column (integer hours; NULL means the server maximum) to `snd_files`
|
||||
- add the migration to both stores
|
||||
- in `createSndFile`, store the storage time
|
||||
|
||||
Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`:
|
||||
|
||||
- `getXFTPClient` takes a proof for the session as a parameter, `SessionId -> IO (Maybe EntitlementProof)`, beside the callback it already takes for a closed client. The client config holds no credential and no keys
|
||||
- `getXFTPServerClient` passes a function that generates the proof over the session id from the configured issuer keys, and only for a server of this user, matched by the key hash that TLS pins, so a file description of the sender cannot direct the entitlement to another server. A server that is not the user's, a missing credential, or a failure to generate gives `Nothing`, with the failure logged
|
||||
- `xftpClientHandshakeV1` calls it with the session id from the connection, and sends the result in the handshake
|
||||
- `agentXFTPNewChunk` reads the storage time from the send record and sends FNEW with it
|
||||
- `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica`
|
||||
|
||||
Completion:
|
||||
|
||||
- `createXFTPChunk` returns the granted expiry as `Maybe GrantedStorageTime`; `SndFileChunkReplica` and `NewSndChunkReplica` carry `expiresAt :: Maybe GrantedStorageTime`
|
||||
- persist it in a nullable `replica_expires_at` column on `snd_file_chunk_replicas` (added to the entitlement migration): `createSndFileReplica` stores `epochSeconds`, `getSndFile` and `getNextSndChunkToUpload` read it back into `GSTExpires`
|
||||
- on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord`
|
||||
- `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later)
|
||||
|
||||
Testing:
|
||||
|
||||
- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys` and the credential for the user, send a file requesting a number of hours above the default and below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default)
|
||||
- the same upload without the credential is capped at the default maximum
|
||||
- the expiry is written before the status, because `BlockingInfo`'s notice parser is terminal (`A.takeByteString`), so any field after the blocking info makes the record unparseable and the file is dropped on restart. Every field added to `AddFile` must go before the status
|
||||
- store log round trip in `tests/CoreTests/StoreLogTests.hs`, in the shape of the SMP store log test: a file record survives a write, a read into the store, and compaction, with and without the expiry, including a file blocked with a notice in both cases
|
||||
|
||||
## simplex-chat
|
||||
|
||||
- remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI
|
||||
- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent
|
||||
- pass the user's credential to the agent when it is created, and through `setUserEntitlement` when the badge changes, in the same places that pass and update the user's servers
|
||||
- pass the storage time to `xftpSendFile`
|
||||
- retain the `maxXFTPFileSize` size limit
|
||||
- reuse `verifyEntitlement` for peer-badge verification
|
||||
- import the issuer public keys from the shared simplexmq constant
|
||||
|
||||
## State
|
||||
|
||||
Steps 2 to 5 are implemented in simplexmq. Step 1 and step 6 belong to the chat branch that carries badges.
|
||||
|
||||
## Order
|
||||
|
||||
1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges.
|
||||
2. Add the new XFTP version, the FNEW storage time, and the response.
|
||||
3. Change the server configuration, store, expiration, and store log.
|
||||
4. Move the proof to the handshake: the handshake field, the session state on the server, and the proof for the session on the client.
|
||||
5. Hold the credential per user in the agent, and add the API to replace it.
|
||||
6. Wire chat to pass the credential and the storage time.
|
||||
+27
-6
@@ -1,4 +1,4 @@
|
||||
Version 3, 2025-01-24
|
||||
Version 4, 2026-08-08
|
||||
|
||||
# SimpleX File Transfer Protocol
|
||||
|
||||
@@ -50,11 +50,12 @@ The objective of SimpleX File Transfer Protocol (XFTP) is to facilitate the secu
|
||||
|
||||
XFTP is implemented as an application level protocol on top of HTTP2 and TLS.
|
||||
|
||||
This document describes XFTP protocol version 3. The version history:
|
||||
This document describes XFTP protocol version 4. The version history:
|
||||
|
||||
- v1: initial version
|
||||
- v2: authenticated commands - added basic auth support for commands
|
||||
- v3: blocked files - added BLOCKED error type for policy violations
|
||||
- v4: server public information and entitlement proof in handshake, file storage time in FNEW and SIDS
|
||||
|
||||
The protocol describes the set of commands that senders and recipients can send to XFTP routers to create, upload, download and delete data packets of several pre-defined sizes. XFTP routers SHOULD support packets of 4 sizes: 64KB, 256KB, 1MB and 4MB (1KB = 1024 bytes, 1MB = 1024KB).
|
||||
|
||||
@@ -329,7 +330,7 @@ Once TLS handshake is complete, client and router will exchange blocks of fixed
|
||||
|
||||
```abnf
|
||||
paddedRouterHello = <padded(routerHello, 16384)>
|
||||
routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey ignoredPart
|
||||
routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey webIdentityProof serverInfo ignoredPart
|
||||
xftpVersionRange = minXftpVersion maxXftpVersion
|
||||
minXftpVersion = xftpVersion
|
||||
maxXftpVersion = xftpVersion
|
||||
@@ -338,15 +339,27 @@ sessionIdentifier = shortString
|
||||
routerCerts = length 1*routerCert ; NonEmpty list of certificates in chain
|
||||
routerCert = originalLength <x509encoded>
|
||||
signedRouterKey = originalLength <x509encoded> ; signed by router certificate
|
||||
webIdentityProof = shortString ; signature over the web client challenge and sessionIdentifier, empty when the client sent no challenge
|
||||
serverInfo = %s"0" / (%s"1" largeString) ; JSON server public information, sent when maxXftpVersion is 4 or above
|
||||
|
||||
paddedClientHello = <padded(clientHello, 16384)>
|
||||
clientHello = xftpVersion keyHash ignoredPart
|
||||
clientHello = xftpVersion keyHash entitlementProof ignoredPart
|
||||
; chosen XFTP protocol version - must be the maximum supported version
|
||||
; within the range offered by the router
|
||||
|
||||
entitlementProof = %s"0" / (%s"1" issuerKeyIndex bbsProof entitlement)
|
||||
; proof of the user entitlement, encoded from v4, bound to sessionIdentifier
|
||||
issuerKeyIndex = 2*2OCTET ; Word16 index of the issuer public key
|
||||
bbsProof = largeString
|
||||
entitlement = entExpires entName entExtra
|
||||
entExpires = shortString ; expiration as an ISO8601 UTC timestamp
|
||||
entName = shortString ; e.g. "supporter", "legend"
|
||||
entExtra = largeString ; opaque to the router
|
||||
|
||||
xftpVersion = 2*2OCTET ; Word16 version number
|
||||
keyHash = shortString
|
||||
shortString = length length*OCTET
|
||||
largeString = originalLength *OCTET
|
||||
length = 1*1OCTET
|
||||
originalLength = 2*2OCTET
|
||||
ignoredPart = *OCTET
|
||||
@@ -432,7 +445,7 @@ Routers SHOULD support basic auth with this command, to allow only router owners
|
||||
The syntax is:
|
||||
|
||||
```abnf
|
||||
register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth
|
||||
register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth fileStorageTime
|
||||
fileInfo = sndKey size digest
|
||||
sndKey = length x509encoded
|
||||
size = 4*4 OCTET ; Word32 big-endian
|
||||
@@ -440,19 +453,27 @@ digest = length *OCTET
|
||||
rcvPublicAuthKeys = length 1*rcvPublicAuthKey
|
||||
rcvPublicAuthKey = length x509encoded
|
||||
basicAuth = "0" / "1" length *OCTET
|
||||
fileStorageTime = %s"0" / (%s"1" storageHours)
|
||||
; encoded from v4; absent or zero requests the maximum the router allows
|
||||
storageHours = 4*4 OCTET ; Word32 big-endian
|
||||
|
||||
x509encoded = <binary X509 key encoding>
|
||||
|
||||
length = 1*1 OCTET
|
||||
```
|
||||
|
||||
`fileStorageTime` requests how long the router stores the data packet. The router grants the smaller of the request and the maximum it allows for the entitlement presented in the handshake, and returns the granted expiration in `sndIds`.
|
||||
|
||||
If the data packet is registered successfully, the router must send `sndIds` response with the sender's and recipients' data packet IDs:
|
||||
|
||||
```abnf
|
||||
sndIds = %s"SIDS " senderId recipientIds
|
||||
sndIds = %s"SIDS " senderId recipientIds grantedStorageTime
|
||||
senderId = length *OCTET
|
||||
recipientIds = length 1*recipientId
|
||||
recipientId = length *OCTET
|
||||
grantedStorageTime = %s"0" / (%s"1" grantedExpires) ; encoded from v4
|
||||
grantedExpires = %s"T" expiresAt
|
||||
expiresAt = 8*8 OCTET ; Int64 big-endian, seconds since epoch
|
||||
```
|
||||
|
||||
#### Add data packet recipients
|
||||
|
||||
@@ -0,0 +1,109 @@
|
||||
# XFTP variable file storage time
|
||||
|
||||
## Summary
|
||||
|
||||
The server stores a storage time for each file. The sender sets it in the FNEW command. The client may present a proof of an entitlement in the handshake to raise the maximum storage time the server allows. The proof is bound to the TLS session, so it cannot be reused for another session.
|
||||
|
||||
An entitlement belongs to the user, not to a file: the client presents it once per connection, and the server applies it to everything the client does in that session. The server can also vary other limits, such as throttling, by the entitlement.
|
||||
|
||||
## Entitlement
|
||||
|
||||
An entitlement is a name, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entName` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send.
|
||||
|
||||
The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here.
|
||||
|
||||
```
|
||||
entitlement = entExpires entName entExtra
|
||||
entExpires = shortString ; expiration as a UTCTime ISO8601 string
|
||||
entName = shortString ; e.g. "supporter", "legend"
|
||||
entExtra = largeString ; opaque, interpretation out of scope
|
||||
|
||||
entitlementProof = issuerKeyIndex bbsProof entitlement
|
||||
issuerKeyIndex = 2*2 OCTET ; Word16, network byte order
|
||||
bbsProof = largeString ; BBS proof bytes
|
||||
```
|
||||
|
||||
The presentation header that the BBS proof is generated over is not transmitted; the server takes it from the session (see [Binding](#binding)), which is what binds the proof.
|
||||
|
||||
### Issuer keys
|
||||
|
||||
Client apps and servers share one list of issuer public keys, indexed by `issuerKeyIndex`. The secret key for the current index is held by the service that issues entitlements, on conditions that are out of scope here, such as payment.
|
||||
|
||||
The list holds eight keys so that the issuing service can rotate its current key without an app or server release: the next index is already known to every app and server. Each rotation consumes one index, so a new key has to be added to client apps and servers eventually, and released before the list is exhausted.
|
||||
|
||||
## Storage time
|
||||
|
||||
```
|
||||
fileStorageTime = %s"0" / (%s"1" storageHours)
|
||||
storageHours = 4*4 OCTET ; Word32, network byte order
|
||||
```
|
||||
|
||||
The storage time is an optional number of hours. Absent (`%s"0"`), or present as zero hours, requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value above zero requests that number of hours, and the server grants the smaller of it and the maximum.
|
||||
|
||||
## Handshake, new XFTP version
|
||||
|
||||
The client handshake carries the entitlement proof.
|
||||
|
||||
```
|
||||
clientHandshake = xftpVersion keyHash optEntitlementProof
|
||||
optEntitlementProof = %s"0" / (%s"1" entitlementProof)
|
||||
```
|
||||
|
||||
`xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof.
|
||||
|
||||
The server verifies the proof when it accepts the handshake and keeps the result for the session; further handshakes on the same connection keep that result and verify nothing, so a session costs one verification however many handshakes it makes. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures.
|
||||
|
||||
## Commands
|
||||
|
||||
The new protocol version extends FNEW with the storage time.
|
||||
|
||||
```
|
||||
fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime
|
||||
```
|
||||
|
||||
`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode no `fileStorageTime`, and the server applies the default storage time.
|
||||
|
||||
## Responses
|
||||
|
||||
FNEW extends the SIDS response with the granted storage.
|
||||
|
||||
```
|
||||
sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime
|
||||
optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime)
|
||||
grantedStorageTime = grantedExpires
|
||||
grantedExpires = %s"T" expiresAt
|
||||
expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order
|
||||
```
|
||||
|
||||
`grantedExpires` returns the absolute expiration — the same value stored for the file. The sum encoding retains a one-character prefix so further variants can be added. Version 3 and earlier omit `optGrantedStorageTime` entirely; a client decoding such a response reads it as absent. `senderId` and `rcvIds` are defined by the current XFTP protocol.
|
||||
|
||||
## Binding
|
||||
|
||||
The presentation header binds the proof to the TLS session, so a proof presented on any other session fails to verify.
|
||||
|
||||
```
|
||||
presHeader = sessionId
|
||||
```
|
||||
|
||||
`sessionId` is the TLS session identifier, the TLS unique channel binding. Both sides take it from the connection: the client has it once TLS is established, and the client checks that the identifier the server sends in its handshake matches.
|
||||
|
||||
Binding to the session is what stops a proof being replayed by another client. A proof is not bound to a file, because the entitlement belongs to the user and authorises everything the client does in that session.
|
||||
|
||||
BBS proofs of one credential are unlinkable, but every proof discloses the same `entExpires`, `entName` and `entExtra`, so a server can link the sessions of one holder by that triple, and two servers can correlate them. The issuing service decides how identifying it is: `entExpires` set to the same instant for everyone who buys in the same period, and an `entExtra` that carries nothing per-holder, make the holders of that period indistinguishable.
|
||||
|
||||
## Maximum storage time
|
||||
|
||||
The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server honours an entitlement for 24 hours after its expiration; past that grace it is treated as no proof.
|
||||
|
||||
If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. The expiration is rounded up to the hour, stored, and returned as `grantedExpires`.
|
||||
|
||||
## Encoding primitives
|
||||
|
||||
```
|
||||
shortString = length *OCTET ; 0-255 bytes
|
||||
largeString = length2 *OCTET
|
||||
length = 1*1 OCTET
|
||||
length2 = 2*2 OCTET ; Word16, network byte order
|
||||
```
|
||||
|
||||
`senderId`, `rcvIds`, `fileInfo`, `sndKey`, `digest`, `rcvKeys`, `optBasicAuth`, and `sessionId` are defined by the current XFTP and SMP protocols.
|
||||
+4
-1
@@ -1,7 +1,7 @@
|
||||
cabal-version: 3.0
|
||||
|
||||
name: simplexmq
|
||||
version: 7.1.0.4
|
||||
version: 7.1.0.5
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -135,6 +135,7 @@ library
|
||||
Simplex.Messaging.Crypto.Lazy
|
||||
Simplex.Messaging.Crypto.Ratchet
|
||||
Simplex.Messaging.Crypto.BBS
|
||||
Simplex.Messaging.Crypto.Entitlement
|
||||
Simplex.Messaging.Crypto.SNTRUP761
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
@@ -192,6 +193,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
|
||||
else
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.SQLite
|
||||
@@ -245,6 +247,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
|
||||
Simplex.Messaging.Agent.Store.SQLite.Util
|
||||
if flag(client_postgres) || flag(server_postgres)
|
||||
exposed-modules:
|
||||
|
||||
@@ -50,11 +50,12 @@ import qualified Data.Set as S
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Data.Word (Word32)
|
||||
import Simplex.FileTransfer.Chunks (toKB)
|
||||
import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize)
|
||||
import Simplex.FileTransfer.Crypto
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime, SFileParty (..))
|
||||
import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
|
||||
import qualified Simplex.FileTransfer.Transport as XFTP
|
||||
import Simplex.FileTransfer.Types
|
||||
@@ -350,8 +351,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
|
||||
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m ()
|
||||
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
|
||||
xftpSendFile' c userId file numRecipients = do
|
||||
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId
|
||||
xftpSendFile' c userId file numRecipients storageHours = do
|
||||
g <- asks random
|
||||
prefixPath <- lift $ getPrefixPath "snd.xftp"
|
||||
createDirectory prefixPath
|
||||
@@ -359,7 +360,7 @@ xftpSendFile' c userId file numRecipients = do
|
||||
key <- atomically $ C.randomSbKey g
|
||||
nonce <- atomically $ C.randomCbNonce g
|
||||
-- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours
|
||||
lift . void $ getXFTPSndWorker True c Nothing
|
||||
pure fId
|
||||
|
||||
@@ -375,7 +376,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si
|
||||
liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
|
||||
key <- atomically $ C.randomSbKey g
|
||||
nonce <- atomically $ C.randomCbNonce g
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest}
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing
|
||||
lift . void $ getXFTPSndWorker True c Nothing
|
||||
pure fId
|
||||
|
||||
@@ -405,7 +406,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
prepareFile _ SndFile {prefixPath = Nothing} =
|
||||
throwE $ INTERNAL "no prefix path"
|
||||
prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do
|
||||
SndFile {numRecipients, chunks} <-
|
||||
SndFile {numRecipients, chunks, storageHours} <-
|
||||
if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
|
||||
then do
|
||||
fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
|
||||
@@ -424,7 +425,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks
|
||||
-- concurrently?
|
||||
-- separate worker to create chunks? record retries and delay on snd_file_chunks?
|
||||
srvs <- forM pendingChunks $ createChunk numRecipients'
|
||||
srvs <- forM pendingChunks $ createChunk numRecipients' storageHours
|
||||
let allSrvs = S.fromList $ preparedSrvs <> srvs
|
||||
lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv)
|
||||
withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
|
||||
@@ -454,8 +455,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of
|
||||
[] -> Left ch
|
||||
SndFileChunkReplica {server} : _ -> Right server
|
||||
createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
|
||||
createChunk numRecipients' ch = do
|
||||
createChunk :: Int -> Maybe Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
|
||||
createChunk numRecipients' storageHours ch = do
|
||||
liftIO $ assertAgentForeground c
|
||||
(replica, ProtoServerWithAuth srv _) <- tryCreate
|
||||
withStore' c $ \db -> createSndFileReplica db ch replica
|
||||
@@ -482,7 +483,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
|
||||
when deleted $ throwE $ FILE NO_FILE
|
||||
withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
|
||||
replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
|
||||
replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageHours
|
||||
pure (replica, srvAuth)
|
||||
|
||||
sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
|
||||
@@ -543,7 +544,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
|
||||
notify c sndFileEntityId $ SFPROG uploaded total
|
||||
when complete $ do
|
||||
(sndDescr, rcvDescrs) <- sndFileToDescrs sf
|
||||
notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
|
||||
notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks)
|
||||
lift . forM_ prefixPath $ removePath <=< toFSFilePath
|
||||
withStore' c $ \db -> updateSndFileComplete db sndFileId
|
||||
where
|
||||
@@ -577,6 +578,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
|
||||
let chunkSize = FileSize $ sndChunkSize ch
|
||||
replicas = [FileChunkReplica {server, replicaId, replicaKey}]
|
||||
pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
|
||||
sndFileExpiresAt :: [SndFileChunk] -> Maybe GrantedStorageTime
|
||||
sndFileExpiresAt chunks' = fmap minimum $ L.nonEmpty =<< mapM chunkExpiresAt chunks'
|
||||
where
|
||||
chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas)
|
||||
createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient]
|
||||
createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
|
||||
where
|
||||
|
||||
@@ -36,8 +36,10 @@ import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -57,6 +59,7 @@ import Network.Socket (HostName)
|
||||
import Simplex.FileTransfer.Chunks
|
||||
import Simplex.FileTransfer.Protocol
|
||||
import Simplex.FileTransfer.Transport
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
|
||||
import Simplex.Messaging.Client
|
||||
( NetworkConfig (..),
|
||||
NetworkRequestMode (..),
|
||||
@@ -84,7 +87,7 @@ import Simplex.Messaging.Protocol
|
||||
SenderId,
|
||||
pattern NoEntity,
|
||||
)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), SessionId, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -126,8 +129,8 @@ defaultXFTPClientConfig =
|
||||
clientALPN = Just alpnSupportedXFTPhandshakes
|
||||
}
|
||||
|
||||
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
|
||||
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do
|
||||
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (SessionId -> IO (Maybe EntitlementProof)) -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
|
||||
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs mkEntitlementProof disconnected = runExceptT $ do
|
||||
let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
|
||||
ProtocolServer _ host port keyHash = srv
|
||||
useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
|
||||
@@ -146,21 +149,23 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
|
||||
thParams@THandleParams {thVersion} <- case sessionALPN of
|
||||
Just alpn
|
||||
| alpn == xftpALPNv1 || alpn == httpALPN11 ->
|
||||
xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
|
||||
xftpClientHandshakeV1 serverVRange keyHash http2Client mkEntitlementProof thParams0
|
||||
_ -> pure thParams0
|
||||
logDebug $ "Client negotiated protocol: " <> tshow thVersion
|
||||
let c = XFTPClient {http2Client, thParams, transportSession, config}
|
||||
atomically $ writeTVar clientVar $ Just c
|
||||
pure c
|
||||
|
||||
xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
|
||||
xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
|
||||
shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake
|
||||
xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> (SessionId -> IO (Maybe EntitlementProof)) -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
|
||||
xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} mkEntitlementProof thParams0 = do
|
||||
shs@XFTPServerHandshake {authPubKey = ck, serverInfoBytes} <- getServerHandshake
|
||||
(vr, sk) <- processServerHandshake shs
|
||||
let v = maxVersion vr
|
||||
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
|
||||
ep <- if v >= fileStorageTimeXFTPVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing
|
||||
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof = ep}
|
||||
let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
|
||||
pure thParams0 {thAuth, thVersion = v, thServerVRange = vr}
|
||||
serverInfo = J.eitherDecodeStrict' <$> serverInfoBytes
|
||||
pure thParams0 {thAuth, thVersion = v, thServerVRange = vr, serverInfo}
|
||||
where
|
||||
getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
|
||||
getServerHandshake = do
|
||||
@@ -253,10 +258,11 @@ createXFTPChunk ::
|
||||
FileInfo ->
|
||||
NonEmpty C.APublicAuthKey ->
|
||||
Maybe BasicAuth ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rcps auth_ =
|
||||
sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
|
||||
(FRSndIds sId rIds, body) -> noFile body (sId, rIds)
|
||||
Maybe Word32 ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime)
|
||||
createXFTPChunk c spKey file rcps auth_ storageHours =
|
||||
sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageHours) Nothing >>= \case
|
||||
(FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs)
|
||||
(r, _) -> throwE $ unexpectedResponse r
|
||||
|
||||
addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ->
|
||||
|
||||
@@ -22,6 +22,7 @@ module Simplex.FileTransfer.Protocol
|
||||
FileCommand (..),
|
||||
FileCmd (..),
|
||||
FileInfo (..),
|
||||
GrantedStorageTime (..),
|
||||
XFTPFileId,
|
||||
FileResponse (..),
|
||||
xftpBlockSize,
|
||||
@@ -38,12 +39,13 @@ import qualified Data.Aeson.TH as J
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word32)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub)
|
||||
import Simplex.Messaging.Client (authTransmission)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
@@ -175,7 +177,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
|
||||
{-# INLINE protocolError #-}
|
||||
|
||||
data FileCommand (p :: FileParty) where
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Word32 -> FileCommand FSender
|
||||
FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
|
||||
FPUT :: FileCommand FSender
|
||||
FDEL :: FileCommand FSender
|
||||
@@ -196,12 +198,27 @@ data FileInfo = FileInfo
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Encoding GrantedStorageTime where
|
||||
smpEncode = \case
|
||||
GSTExpires t -> smpEncode ('T', t)
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
'T' -> GSTExpires <$> smpP
|
||||
_ -> fail "bad GrantedStorageTime"
|
||||
|
||||
type XFTPFileId = EntityId
|
||||
|
||||
instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
|
||||
type Tag (FileCommand p) = FileCommandTag p
|
||||
encodeProtocol _v = \case
|
||||
FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
|
||||
encodeProtocol v = \case
|
||||
FNEW file rKeys auth_ st
|
||||
| v >= fileStorageTimeXFTPVersion -> fnew <> e st
|
||||
| otherwise -> fnew
|
||||
where
|
||||
fnew = e (FNEW_, ' ', file, rKeys, auth_)
|
||||
FADD rKeys -> e (FADD_, ' ', rKeys)
|
||||
FPUT -> e FPUT_
|
||||
FDEL -> e FDEL_
|
||||
@@ -235,10 +252,14 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
|
||||
type Tag FileCmd = FileCmdTag
|
||||
encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
|
||||
|
||||
protocolP _v = \case
|
||||
protocolP v = \case
|
||||
FCT SFSender tag ->
|
||||
FileCmd SFSender <$> case tag of
|
||||
FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
|
||||
FNEW_
|
||||
| v >= fileStorageTimeXFTPVersion -> fnewP smpP
|
||||
| otherwise -> fnewP (pure Nothing)
|
||||
where
|
||||
fnewP stP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP
|
||||
FADD_ -> FADD <$> _smpP
|
||||
FPUT_ -> pure FPUT
|
||||
FDEL_ -> pure FDEL
|
||||
@@ -292,7 +313,7 @@ instance ProtocolMsgTag FileResponseTag where
|
||||
_ -> Nothing
|
||||
|
||||
data FileResponse
|
||||
= FRSndIds SenderId (NonEmpty RecipientId)
|
||||
= FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime)
|
||||
| FRRcvIds (NonEmpty RecipientId)
|
||||
| FRFile RcvPublicDhKey C.CbNonce
|
||||
| FROk
|
||||
@@ -303,7 +324,9 @@ data FileResponse
|
||||
instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
|
||||
type Tag FileResponse = FileResponseTag
|
||||
encodeProtocol v = \case
|
||||
FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
|
||||
FRSndIds fId rIds gs
|
||||
| v >= fileStorageTimeXFTPVersion -> e (FRSndIds_, ' ', fId, rIds, gs)
|
||||
| otherwise -> e (FRSndIds_, ' ', fId, rIds)
|
||||
FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
|
||||
FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
|
||||
FROk -> e FROk_
|
||||
@@ -315,8 +338,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
|
||||
e :: Encoding a => a -> ByteString
|
||||
e = smpEncode
|
||||
|
||||
protocolP _v = \case
|
||||
FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
|
||||
protocolP v = \case
|
||||
FRSndIds_
|
||||
| v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP
|
||||
| otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure Nothing
|
||||
FRRcvIds_ -> FRRcvIds <$> _smpP
|
||||
FRFile_ -> FRFile <$> _smpP <*> smpP
|
||||
FROk_ -> pure FROk
|
||||
|
||||
@@ -23,18 +23,22 @@ import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Except
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Bifunctor (first)
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import Data.ByteString.Builder (Builder, byteString)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
import Data.Time.Clock.System (systemSeconds, utcToSystemTime)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.X509 as X
|
||||
@@ -54,6 +58,8 @@ import Simplex.FileTransfer.Server.Store
|
||||
import Simplex.FileTransfer.Server.StoreLog
|
||||
import Simplex.FileTransfer.Transport
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
|
||||
import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), EntitlementVerification (..), verifyEntitlement)
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
@@ -66,7 +72,7 @@ import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.SystemTime
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), EntitlementConfig (..), SessionEntitlement (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
|
||||
@@ -120,17 +126,20 @@ runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s ->
|
||||
runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
|
||||
|
||||
data Handshake
|
||||
= HandshakeSent C.PrivateKeyX25519
|
||||
= HandshakeSent C.PrivateKeyX25519 EntitlementChecked
|
||||
| HandshakeAccepted (THandleParams XFTPVersion 'TServer)
|
||||
|
||||
-- | the entitlement of the session is resolved once, however many handshakes it has
|
||||
data EntitlementChecked = EntNotChecked | EntChecked (Maybe SessionEntitlement)
|
||||
|
||||
xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
|
||||
mapM_ (expireServerFiles Nothing) fileExpiration
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange, information} started = do
|
||||
expireServerFiles Nothing fileExpiration
|
||||
restoreServerStats
|
||||
raceAny_
|
||||
( runServer
|
||||
: expireFilesThread_ cfg
|
||||
<> serverStatsThread_ cfg
|
||||
: expireFiles fileExpiration
|
||||
: serverStatsThread_ cfg
|
||||
<> prometheusMetricsThread_ cfg
|
||||
<> controlPortThread_ cfg
|
||||
)
|
||||
@@ -174,12 +183,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
Nothing
|
||||
| sniUsed && not webHello -> throwE SESSION
|
||||
| otherwise -> processHello Nothing
|
||||
Just (HandshakeSent pk)
|
||||
Just (HandshakeSent pk ent_)
|
||||
| webHello -> processHello (Just pk)
|
||||
| otherwise -> processClientHandshake pk
|
||||
| otherwise -> processClientHandshake pk ent_
|
||||
Just (HandshakeAccepted thParams)
|
||||
| webHello -> processHello (serverPrivKey <$> thAuth thParams)
|
||||
| webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth)
|
||||
| webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (EntChecked $ peerEntitlement auth)
|
||||
| otherwise -> pure $ Just thParams
|
||||
either sendError pure r
|
||||
where
|
||||
@@ -196,28 +205,35 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
| otherwise -> throwE HANDSHAKE
|
||||
rng <- asks random
|
||||
k <- atomically $ TM.lookup sessionId sessions >>= \case
|
||||
Just (HandshakeSent pk') -> pure $ C.publicKey pk'
|
||||
_ -> do
|
||||
Just (HandshakeSent pk' _) -> pure $ C.publicKey pk'
|
||||
s' -> do
|
||||
kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_
|
||||
fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions
|
||||
let ent_ = case s' of
|
||||
Just (HandshakeAccepted thParams) -> EntChecked $ peerEntitlement =<< thAuth thParams
|
||||
_ -> EntNotChecked
|
||||
fst kp <$ TM.insert sessionId (HandshakeSent (snd kp) ent_) sessions
|
||||
let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
|
||||
webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_
|
||||
let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof}
|
||||
serverInfoBytes = LB.toStrict . J.encode <$> information
|
||||
let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes}
|
||||
shs <- encodeXftp hs
|
||||
#ifdef slow_servers
|
||||
lift randomDelay
|
||||
#endif
|
||||
liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs
|
||||
pure Nothing
|
||||
processClientHandshake pk = do
|
||||
processClientHandshake pk ent_ = do
|
||||
unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE
|
||||
body <- liftHS $ C.unPad bodyHead
|
||||
XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body
|
||||
XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body
|
||||
kh <- asks serverIdentity
|
||||
unless (keyHash == kh) $ throwE HANDSHAKE
|
||||
case compatibleVRange' xftpServerVRange v of
|
||||
Just (Compatible vr) -> do
|
||||
let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
|
||||
ent <- case ent_ of
|
||||
EntChecked ent -> pure ent
|
||||
EntNotChecked -> lift $ verifiedEntitlement entitlementProof
|
||||
let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing}
|
||||
thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
|
||||
atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
|
||||
#ifdef slow_servers
|
||||
@@ -226,6 +242,19 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS)
|
||||
pure Nothing
|
||||
Nothing -> throwE HANDSHAKE
|
||||
verifiedEntitlement :: Maybe EntitlementProof -> M s (Maybe SessionEntitlement)
|
||||
verifiedEntitlement ep =
|
||||
pure ep $>>= \proof@EntitlementProof {entitlement = Entitlement {entitlementName, expiresAt = expiresAtTs}} -> do
|
||||
entCfg <- asks $ M.lookup entitlementName . fileStorageEntitlements . config
|
||||
now <- liftIO getSystemSeconds
|
||||
let expiresAt = RoundedSystemTime $ systemSeconds $ utcToSystemTime expiresAtTs
|
||||
case entCfg of
|
||||
Just cfg | entitlementValid now expiresAt -> do
|
||||
keys <- asks $ entitlementKeys . config
|
||||
liftIO (verifyEntitlement keys (BBSPresHeader sessionId) proof) >>= \case
|
||||
EVValid -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg}
|
||||
r -> Nothing <$ logError ("entitlement not verified: " <> tshow r)
|
||||
_ -> pure Nothing
|
||||
sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer))
|
||||
sendError err = do
|
||||
runExceptT (encodeXftp err) >>= \case
|
||||
@@ -243,10 +272,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
saveServerStats
|
||||
logNote "Server stopped"
|
||||
|
||||
expireFilesThread_ :: XFTPServerConfig s -> [M s ()]
|
||||
expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
|
||||
expireFilesThread_ _ = []
|
||||
|
||||
expireFiles :: ExpirationConfig -> M s ()
|
||||
expireFiles expCfg = do
|
||||
let interval = checkInterval expCfg * 1000000
|
||||
@@ -402,8 +427,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
|
||||
case xftpDecodeTServer thParams bodyHead of
|
||||
Right (Right t@(_, _, (corrId, fId, _))) -> do
|
||||
let THandleParams {thAuth} = thParams
|
||||
ent = peerEntitlement =<< thAuth
|
||||
verifyXFTPTransmission thAuth t >>= \case
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest body req
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest ent body req
|
||||
VRFailed e -> send (FRErr e) Nothing
|
||||
where
|
||||
send resp = sendXFTPResponse (corrId, fId, resp)
|
||||
@@ -443,7 +469,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
|
||||
verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult
|
||||
verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
|
||||
case cmd of
|
||||
FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
|
||||
FileCmd SFSender (FNEW file rcps auth' st) -> pure $ XFTPReqNew file rcps auth' st `verifyWith` sndKey file
|
||||
FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
|
||||
FileCmd party _ -> verifyCmd party
|
||||
where
|
||||
@@ -464,9 +490,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
|
||||
-- TODO verify with DH authorization
|
||||
req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
|
||||
|
||||
processXFTPRequest :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH)
|
||||
processXFTPRequest :: forall s. FileStoreClass s => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest ent HTTP2Body {bodyPart} = \case
|
||||
XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH)
|
||||
where
|
||||
allowNew = do
|
||||
XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
|
||||
@@ -483,29 +509,42 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
XFTPReqPing -> noFile FRPong
|
||||
where
|
||||
noFile resp = pure (resp, Nothing)
|
||||
createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse
|
||||
createFile file rks = do
|
||||
createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse
|
||||
createFile file rks storageHours = do
|
||||
st <- asks fileStore
|
||||
r <- runExceptT $ do
|
||||
sizes <- asks $ allowedChunkSizes . config
|
||||
unless (size file `elem` sizes) $ throwE SIZE
|
||||
ts <- liftIO getFileTime
|
||||
now <- liftIO getSystemSeconds
|
||||
maxSeconds <- lift $ storageMaxSeconds now
|
||||
let nowSeconds = roundedSeconds now
|
||||
ts = RoundedSystemTime $ (nowSeconds `div` fileTimePrecision) * fileTimePrecision
|
||||
secs = case storageHours of
|
||||
Just hours | hours > 0 -> min maxSeconds (fromIntegral hours * 3600)
|
||||
_ -> maxSeconds
|
||||
fileExpiresAt = RoundedSystemTime $ ((nowSeconds + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
|
||||
-- TODO validate body empty
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
|
||||
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
|
||||
lift $ withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts EntityActive
|
||||
logAddFile sl sId file ts (Just fileExpiresAt) EntityActive
|
||||
logAddRecipients sl sId rcps
|
||||
stats <- asks serverStats
|
||||
lift $ incFileStat filesCreated
|
||||
liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
|
||||
let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
|
||||
pure $ FRSndIds sId rIds
|
||||
pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt)))
|
||||
pure $ either FRErr id r
|
||||
addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
|
||||
addFileRetry st file n ts =
|
||||
storageMaxSeconds :: SystemSeconds -> M s Int64
|
||||
storageMaxSeconds now = do
|
||||
defaultMax <- asks $ ttl . fileExpiration . config
|
||||
pure $ case ent of
|
||||
Just SessionEntitlement {expiresAt, entConfig} | entitlementValid now expiresAt -> max (storageTime entConfig) defaultMax
|
||||
_ -> defaultMax
|
||||
addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
|
||||
addFileRetry st file n ts expiresAt =
|
||||
retryAdd n $ \sId -> runExceptT $ do
|
||||
ExceptT $ addFile st sId file ts EntityActive
|
||||
ExceptT $ addFile st sId file ts expiresAt EntityActive
|
||||
pure sId
|
||||
addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient)
|
||||
addRecipientRetry st n sId rpk =
|
||||
@@ -640,24 +679,25 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
|
||||
liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
|
||||
liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
|
||||
|
||||
getFileTime :: IO RoundedFileTime
|
||||
getFileTime = getRoundedSystemTime
|
||||
entitlementValid :: SystemSeconds -> SystemSeconds -> Bool
|
||||
entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now
|
||||
|
||||
expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
|
||||
expireServerFiles itemDelay expCfg = do
|
||||
st <- asks fileStore
|
||||
us <- asks usedStorage
|
||||
usedStart <- readTVarIO us
|
||||
now <- liftIO getSystemSeconds
|
||||
old <- liftIO $ expireBeforeEpoch expCfg
|
||||
filesCount <- liftIO $ getFileCount st
|
||||
logNote $ "Expiration check: " <> tshow filesCount <> " files"
|
||||
expireLoop st us old
|
||||
expireLoop st us now old
|
||||
usedEnd <- readTVarIO us
|
||||
logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
|
||||
where
|
||||
mbs bs = tshow (bs `div` 1048576) <> "mb"
|
||||
expireLoop st us old = do
|
||||
expired <- liftIO $ expiredFiles st old 10000
|
||||
expireLoop st us now old = do
|
||||
expired <- liftIO $ expiredFiles st now old 10000
|
||||
forM_ expired $ \(sId, filePath_, fileSize) -> do
|
||||
mapM_ threadDelay itemDelay
|
||||
forM_ filePath_ $ \fp ->
|
||||
@@ -670,7 +710,7 @@ expireServerFiles itemDelay expCfg = do
|
||||
unless (null sIds) $ do
|
||||
withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds
|
||||
liftIO $ deleteFiles st sIds
|
||||
expireLoop st us old
|
||||
expireLoop st us now old
|
||||
|
||||
randomId :: Int -> M s ByteString
|
||||
randomId n = atomically . C.randomBytes n =<< asks random
|
||||
|
||||
@@ -37,8 +37,11 @@ import Control.Monad
|
||||
import Crypto.Random
|
||||
import Data.Int (Int64)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Word (Word32)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as T
|
||||
@@ -62,8 +65,11 @@ import System.Directory (doesFileExist)
|
||||
import Simplex.FileTransfer.Server.StoreLog
|
||||
import Simplex.FileTransfer.Transport (VersionRangeXFTP)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import Simplex.Messaging.Transport (EntitlementConfig (..))
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.IO (IOMode (..))
|
||||
@@ -88,7 +94,10 @@ data XFTPServerConfig s = XFTPServerConfig
|
||||
controlPortUserAuth :: Maybe BasicAuth,
|
||||
controlPortAdminAuth :: Maybe BasicAuth,
|
||||
-- | time after which the files can be removed and check interval, seconds
|
||||
fileExpiration :: Maybe ExpirationConfig,
|
||||
fileExpiration :: ExpirationConfig,
|
||||
-- | what each entitlement name grants
|
||||
fileStorageEntitlements :: Map Text EntitlementConfig,
|
||||
entitlementKeys :: Map Word16 BBSPublicKey,
|
||||
-- | timeout to receive file
|
||||
fileTimeout :: Int,
|
||||
-- | time after which inactive clients can be disconnected and check interval, seconds
|
||||
@@ -97,6 +106,8 @@ data XFTPServerConfig s = XFTPServerConfig
|
||||
httpCredentials :: Maybe ServerCredentials,
|
||||
-- | XFTP client-server protocol version range
|
||||
xftpServerVRange :: VersionRangeXFTP,
|
||||
-- | server public information sent in handshake and used to generate static mini-site
|
||||
information :: Maybe ServerPublicInfo,
|
||||
-- stats config - see SMP server config
|
||||
logStatsInterval :: Maybe Int64,
|
||||
logStatsStartTime :: Int64,
|
||||
@@ -171,7 +182,13 @@ defaultFileExpiration =
|
||||
}
|
||||
|
||||
newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
|
||||
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do
|
||||
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
|
||||
let defaultMax = ttl fileExpiration
|
||||
belowDefault = M.filter ((< defaultMax) . storageTime) fileStorageEntitlements
|
||||
unless (M.null belowDefault) $ do
|
||||
forM_ (M.assocs belowDefault) $ \(name, EntitlementConfig {storageTime}) ->
|
||||
logError $ "expire_files_hours_for_" <> name <> " is " <> tshow (storageTime `div` 3600) <> " hours, below expire_files_hours " <> tshow (defaultMax `div` 3600) <> " hours, server not started"
|
||||
exitFailure
|
||||
random <- C.newRandom
|
||||
(store, storeLog) <- case serverStoreCfg of
|
||||
XSCMemory storeLogPath -> do
|
||||
@@ -196,7 +213,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCre
|
||||
pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data XFTPRequest
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Word32)
|
||||
| XFTPReqCmd XFTPFileId FileRec FileCmd
|
||||
| XFTPReqPing
|
||||
|
||||
|
||||
@@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.FileTransfer.Server.Main
|
||||
@@ -13,14 +14,16 @@ module Simplex.FileTransfer.Server.Main
|
||||
xftpServerCLI_,
|
||||
) where
|
||||
|
||||
import Control.Monad (unless, when)
|
||||
import Control.Monad (forM_, unless, when)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Ini (lookupValue, readIniFile)
|
||||
import Data.Ini (Ini, lookupValue, readIniFile)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
@@ -32,6 +35,7 @@ import Simplex.FileTransfer.Server (runXFTPServer)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, AFStoreType (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, readFileStoreType, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase)
|
||||
import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
@@ -40,6 +44,7 @@ import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo (..))
|
||||
import Simplex.Messaging.Server.Main (serverPublicInfo, printSourceCode)
|
||||
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
|
||||
import Simplex.Messaging.Transport (EntitlementConfig (..))
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig)
|
||||
@@ -155,8 +160,14 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
\# db_pool_size = 10\n\n\
|
||||
\# Write database changes to store log file\n\
|
||||
\# db_store_log = off\n\n"
|
||||
<> "# Expire files after the specified number of hours.\n"
|
||||
<> "# Expire files after the specified number of hours.\n\
|
||||
\# The change only affects new files.\n"
|
||||
<> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n")
|
||||
<> "# Expire files after the specified number of hours for the senders that present\n\
|
||||
\# a proof of the entitlement. Must not be below expire_files_hours.\n\
|
||||
\# The change only affects new files.\n\
|
||||
\# expire_files_hours_for_supporter = 168\n\
|
||||
\# expire_files_hours_for_legend = 504\n\n"
|
||||
<> "log_stats = off\n\
|
||||
\\n\
|
||||
\# Log interval for real-time Prometheus metrics\n\
|
||||
@@ -235,13 +246,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
|
||||
logStats = settingIsOn "STORE_LOG" "log_stats" ini
|
||||
c = combine cfgPath . ($ defaultX509Config)
|
||||
printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do
|
||||
printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, fileStorageEntitlements, inactiveClientExpiration} = do
|
||||
putStrLn $ case storeLogFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
putStrLn $ case fileExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
|
||||
_ -> "not expiring files"
|
||||
putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration)
|
||||
forM_ (M.assocs fileStorageEntitlements) $ \(name, EntitlementConfig {storageTime}) ->
|
||||
putStrLn $ "expiring files of " <> T.unpack name <> " after " <> showTTL storageTime
|
||||
putStrLn $ case inactiveClientExpiration of
|
||||
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
||||
_ -> "not expiring inactive clients"
|
||||
@@ -287,10 +298,11 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
|
||||
controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
|
||||
fileExpiration =
|
||||
Just
|
||||
defaultFileExpiration
|
||||
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
|
||||
},
|
||||
defaultFileExpiration
|
||||
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
|
||||
},
|
||||
fileStorageEntitlements = iniEntitlements ini,
|
||||
entitlementKeys = entitlementIssuerKeys,
|
||||
fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
|
||||
inactiveClientExpiration =
|
||||
settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
|
||||
@@ -306,6 +318,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
},
|
||||
httpCredentials = httpCredentials_,
|
||||
xftpServerVRange = supportedFileServerVRange,
|
||||
information = serverPublicInfo ini,
|
||||
logStatsInterval = logStats $> 86400, -- seconds
|
||||
logStatsStartTime = 0, -- seconds from 00:00 UTC
|
||||
serverStatsLogFile = combine logPath "file-server-stats.daily.log",
|
||||
@@ -437,3 +450,10 @@ cliCommandP cfgPath logPath iniFile =
|
||||
( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database"))
|
||||
<> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file"))
|
||||
)
|
||||
|
||||
iniEntitlements :: Ini -> Map T.Text EntitlementConfig
|
||||
iniEntitlements ini =
|
||||
M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")]
|
||||
where
|
||||
readEntitlement (name, key) = (name,) . EntitlementConfig . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini)
|
||||
parseHours key t = maybe (error $ "Error: invalid " <> T.unpack key <> " value: " <> T.unpack t) (3600 *) (readMaybe (T.unpack (T.strip t)) :: Maybe Int64)
|
||||
|
||||
@@ -55,6 +55,7 @@ data FileRec = FileRec
|
||||
filePath :: TVar (Maybe FilePath),
|
||||
recipientIds :: TVar (Set RecipientId),
|
||||
createdAt :: RoundedFileTime,
|
||||
expiresAt :: Maybe RoundedFileTime,
|
||||
fileStatus :: TVar ServerEntityStatus
|
||||
}
|
||||
|
||||
@@ -74,7 +75,7 @@ class FileStoreClass s where
|
||||
type FileStoreConfig s
|
||||
newFileStore :: FileStoreConfig s -> IO s
|
||||
closeFileStore :: s -> IO ()
|
||||
addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
|
||||
addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
|
||||
setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ())
|
||||
addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
|
||||
deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ())
|
||||
@@ -84,7 +85,7 @@ class FileStoreClass s where
|
||||
deleteRecipient :: s -> RecipientId -> FileRec -> IO ()
|
||||
getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey))
|
||||
ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ())
|
||||
expiredFiles :: s -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
|
||||
expiredFiles :: s -> SystemSeconds -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
|
||||
getUsedStorage :: s -> IO Int64
|
||||
getFileCount :: s -> IO Int
|
||||
|
||||
@@ -107,9 +108,9 @@ instance FileStoreClass STMFileStore where
|
||||
|
||||
closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog
|
||||
|
||||
addFile STMFileStore {files} sId fileInfo createdAt status = atomically $
|
||||
addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $
|
||||
ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
|
||||
f <- newFileRec sId fileInfo createdAt status
|
||||
f <- newFileRec sId fileInfo createdAt expiresAt status
|
||||
TM.insert sId f files
|
||||
pure $ Right ()
|
||||
|
||||
@@ -166,14 +167,17 @@ instance FileStoreClass STMFileStore where
|
||||
pure $ Right ()
|
||||
_ -> pure $ Left AUTH
|
||||
|
||||
expiredFiles STMFileStore {files} old _limit = do
|
||||
expiredFiles STMFileStore {files} now old _limit = do
|
||||
fs <- readTVarIO files
|
||||
fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) ->
|
||||
if createdAt + fileTimePrecision < old
|
||||
then do
|
||||
path <- readTVarIO filePath
|
||||
pure $ Just (sId, path, size)
|
||||
else pure Nothing
|
||||
fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) ->
|
||||
let expired = case expiresAt of
|
||||
Just e -> roundedSeconds e < roundedSeconds now
|
||||
Nothing -> createdAt + fileTimePrecision < old
|
||||
in if expired
|
||||
then do
|
||||
path <- readTVarIO filePath
|
||||
pure $ Just (sId, path, size)
|
||||
else pure Nothing
|
||||
|
||||
getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files
|
||||
where
|
||||
@@ -184,12 +188,12 @@ instance FileStoreClass STMFileStore where
|
||||
|
||||
-- Internal STM helpers
|
||||
|
||||
newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
|
||||
newFileRec senderId fileInfo createdAt status = do
|
||||
newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec
|
||||
newFileRec senderId fileInfo createdAt expiresAt status = do
|
||||
recipientIds <- newTVar S.empty
|
||||
filePath <- newTVar Nothing
|
||||
fileStatus <- newTVar status
|
||||
pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
|
||||
pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
|
||||
|
||||
withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a)
|
||||
withFile STMFileStore {files} sId a =
|
||||
|
||||
@@ -55,6 +55,7 @@ import Simplex.Messaging.Transport (EntityId (..))
|
||||
import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
|
||||
import Simplex.Messaging.Server.QueueStore.Postgres ()
|
||||
import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
|
||||
import Simplex.Messaging.SystemTime (roundedSeconds)
|
||||
import Simplex.Messaging.Util (firstRow, tshow)
|
||||
import System.Directory (renameFile)
|
||||
import System.Exit (exitFailure)
|
||||
@@ -82,17 +83,17 @@ instance FileStoreClass PostgresFileStore where
|
||||
closeDBStore dbStore
|
||||
mapM_ closeStoreLog dbStoreLog
|
||||
|
||||
addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt status =
|
||||
addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status =
|
||||
E.uninterruptibleMask_ $ runExceptT $ do
|
||||
void $ withDB "addFile" st $ \db ->
|
||||
E.try
|
||||
( DB.execute
|
||||
db
|
||||
"INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, status) VALUES (?,?,?,?,?,?)"
|
||||
(sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, status)
|
||||
"INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)"
|
||||
(sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status)
|
||||
)
|
||||
>>= either handleDuplicate (pure . Right)
|
||||
withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt status
|
||||
withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status
|
||||
|
||||
setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do
|
||||
assertUpdated $ withDB' "setFilePath" st $ \db ->
|
||||
@@ -131,13 +132,13 @@ instance FileStoreClass PostgresFileStore where
|
||||
|
||||
getFile st party fId = runExceptT $ case party of
|
||||
SFSender -> do
|
||||
row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files WHERE sender_id = ?"
|
||||
row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?"
|
||||
fr <- ExceptT $ rowToFileRec row
|
||||
pure (fr, sndKey (fileInfo fr))
|
||||
SFRecipient -> do
|
||||
row :. Only rcpKeyBs <-
|
||||
loadFileRow
|
||||
"SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
|
||||
"SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
|
||||
fr <- ExceptT $ rowToFileRec row
|
||||
rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs
|
||||
pure (fr, rcpKey)
|
||||
@@ -152,12 +153,12 @@ instance FileStoreClass PostgresFileStore where
|
||||
DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId)
|
||||
withLog "ackFile" st $ \s -> logAckFile s rId
|
||||
|
||||
expiredFiles st old limit =
|
||||
expiredFiles st now old limit =
|
||||
fmap toResult $ withTransaction (dbStore st) $ \db ->
|
||||
DB.query
|
||||
db
|
||||
"SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?"
|
||||
(fileTimePrecision, old, limit)
|
||||
"(SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)"
|
||||
(roundedSeconds now, limit, old - fileTimePrecision, limit)
|
||||
where
|
||||
toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
|
||||
toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))
|
||||
@@ -174,21 +175,21 @@ instance FileStoreClass PostgresFileStore where
|
||||
|
||||
-- Internal helpers
|
||||
|
||||
mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> ServerEntityStatus -> IO FileRec
|
||||
mkFileRec senderId fileInfo path createdAt status = do
|
||||
mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec
|
||||
mkFileRec senderId fileInfo path createdAt expiresAt status = do
|
||||
filePath <- newTVarIO path
|
||||
recipientIds <- newTVarIO S.empty
|
||||
fileStatus <- newTVarIO status
|
||||
pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
|
||||
pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
|
||||
|
||||
type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, ServerEntityStatus)
|
||||
type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
|
||||
|
||||
rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec)
|
||||
rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, status) =
|
||||
rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) =
|
||||
case C.decodePubKey sndKeyBs of
|
||||
Right sndKey -> do
|
||||
let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
|
||||
Right <$> mkFileRec sId fileInfo path createdAt status
|
||||
Right <$> mkFileRec sId fileInfo path createdAt expiresAt status
|
||||
Left _ -> pure $ Left INTERNAL
|
||||
|
||||
-- DB helpers
|
||||
@@ -243,7 +244,7 @@ importFileStore storeLogFilePath dbCfg = do
|
||||
fCnt <- withTransaction (dbStore pgStore) $ \db -> do
|
||||
DB.copy_
|
||||
db
|
||||
"COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, status) FROM STDIN WITH (FORMAT csv)"
|
||||
"COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)"
|
||||
iforM_ (M.toList allFiles) $ \i (sId, fr) -> do
|
||||
DB.putCopyData db =<< fileRecToCSV sId fr
|
||||
when (i > 0 && i `mod` 10000 == 0) $ putStr (" " <> show i <> " files\r") >> hFlush stdout
|
||||
@@ -282,13 +283,13 @@ exportFileStore storeLogFilePath dbCfg = do
|
||||
!fCnt <- withTransaction (dbStore pgStore) $ \db ->
|
||||
DB.fold_
|
||||
db
|
||||
"SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files ORDER BY created_at"
|
||||
"SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at"
|
||||
(0 :: Int)
|
||||
( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, status) ->
|
||||
( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) ->
|
||||
case C.decodePubKey sndKeyBs of
|
||||
Right sndKey -> do
|
||||
let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
|
||||
logAddFile sl sId fileInfo createdAt status
|
||||
logAddFile sl sId fileInfo createdAt expiresAt status
|
||||
forM_ path $ logPutFile sl sId
|
||||
pure (fc + 1)
|
||||
Left _ -> do
|
||||
@@ -326,7 +327,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m ()
|
||||
iforM_ xs f = zipWithM_ f [0 ..] xs
|
||||
|
||||
fileRecToCSV :: SenderId -> FileRec -> IO ByteString
|
||||
fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, fileStatus} = do
|
||||
fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do
|
||||
path <- readTVarIO filePath
|
||||
status <- readTVarIO fileStatus
|
||||
pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n'
|
||||
@@ -338,6 +339,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath,
|
||||
renderField (toField (Binary (C.encodePubKey sndKey))),
|
||||
nullable (toField <$> path),
|
||||
renderField (toField createdAt),
|
||||
nullable (toField <$> expiresAt),
|
||||
quotedField (toField status)
|
||||
]
|
||||
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
|
||||
@@ -20,13 +20,13 @@ module Simplex.FileTransfer.Server.StoreLog
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Composition ((.:), (.::))
|
||||
import Data.Composition ((.:), (.::.))
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -42,7 +42,7 @@ import Simplex.Messaging.Util (bshow)
|
||||
import System.IO
|
||||
|
||||
data FileStoreLogRecord
|
||||
= AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus
|
||||
= AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus
|
||||
| PutFile SenderId FilePath
|
||||
| AddRecipients SenderId (NonEmpty FileRecipient)
|
||||
| DeleteFile SenderId
|
||||
@@ -52,27 +52,37 @@ data FileStoreLogRecord
|
||||
|
||||
instance StrEncoding FileStoreLogRecord where
|
||||
strEncode = \case
|
||||
AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status)
|
||||
AddFile sId file createdAt expiresAt status -> B.concat [strEncode (Str "FNEW", sId, file, createdAt), expE expiresAt, " ", strEncode status]
|
||||
PutFile sId path -> strEncode (Str "FPUT", sId, path)
|
||||
AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
|
||||
DeleteFile sId -> strEncode (Str "FDEL", sId)
|
||||
BlockFile sId info -> strEncode (Str "FBLK", sId, info)
|
||||
AckFile rId -> strEncode (Str "FACK", rId)
|
||||
where
|
||||
expE = maybe "" ((" " <>) . strEncode)
|
||||
strP =
|
||||
A.choice
|
||||
[ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)),
|
||||
[ "FNEW " *> addFileP,
|
||||
"FPUT " *> (PutFile <$> strP_ <*> strP),
|
||||
"FADD " *> (AddRecipients <$> strP_ <*> strP),
|
||||
"FDEL " *> (DeleteFile <$> strP),
|
||||
"FBLK " *> (BlockFile <$> strP_ <*> strP),
|
||||
"FACK " *> (AckFile <$> strP)
|
||||
]
|
||||
where
|
||||
addFileP = do
|
||||
sId <- strP_
|
||||
file <- strP_
|
||||
createdAt <- strP
|
||||
expiresAt <- optional _strP
|
||||
status <- _strP <|> pure EntityActive
|
||||
pure $ AddFile sId file createdAt expiresAt status
|
||||
|
||||
logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
|
||||
logFileStoreRecord = writeStoreLogRecord
|
||||
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO ()
|
||||
logAddFile s = logFileStoreRecord s .:: AddFile
|
||||
logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO ()
|
||||
logAddFile s = logFileStoreRecord s .::. AddFile
|
||||
|
||||
logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
|
||||
logPutFile s = logFileStoreRecord s .: PutFile
|
||||
@@ -102,8 +112,8 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
|
||||
Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
|
||||
_ -> pure ()
|
||||
addToStore = \case
|
||||
AddFile sId file createdAt status
|
||||
| size file > 0 -> addFile st sId file createdAt status
|
||||
AddFile sId file createdAt expiresAt status
|
||||
| size file > 0 -> addFile st sId file createdAt expiresAt status
|
||||
| otherwise -> pure $ Left SIZE
|
||||
PutFile qId path -> setFilePath st qId path
|
||||
AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
|
||||
@@ -118,9 +128,9 @@ writeFileStore s STMFileStore {files, recipients} = do
|
||||
readTVarIO files >>= mapM_ (logFile allRcps)
|
||||
where
|
||||
logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
|
||||
logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do
|
||||
logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do
|
||||
status <- readTVarIO fileStatus
|
||||
logAddFile s senderId fileInfo createdAt status
|
||||
logAddFile s senderId fileInfo createdAt expiresAt status
|
||||
(rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
|
||||
mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
|
||||
mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs
|
||||
|
||||
@@ -12,6 +12,7 @@ module Simplex.FileTransfer.Transport
|
||||
( supportedFileServerVRange,
|
||||
authCmdsXFTPVersion,
|
||||
blockedFilesXFTPVersion,
|
||||
fileStorageTimeXFTPVersion,
|
||||
xftpClientHandshakeStub,
|
||||
alpnSupportedXFTPhandshakes,
|
||||
xftpALPNv1,
|
||||
@@ -36,7 +37,6 @@ module Simplex.FileTransfer.Transport
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative (optional)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
@@ -56,13 +56,14 @@ import Data.Word (Word16, Word32)
|
||||
import Network.HTTP2.Client (HTTP2Error)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
|
||||
import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
import Simplex.Messaging.Util (bshow, tshow, (<$?>))
|
||||
import Simplex.Messaging.Util (bshow, tshow, (<$?>), (<$$>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import System.IO (Handle, IOMode (..), withFile)
|
||||
@@ -97,8 +98,11 @@ authCmdsXFTPVersion = VersionXFTP 2
|
||||
blockedFilesXFTPVersion :: VersionXFTP
|
||||
blockedFilesXFTPVersion = VersionXFTP 3
|
||||
|
||||
fileStorageTimeXFTPVersion :: VersionXFTP
|
||||
fileStorageTimeXFTPVersion = VersionXFTP 4
|
||||
|
||||
currentXFTPVersion :: VersionXFTP
|
||||
currentXFTPVersion = VersionXFTP 3
|
||||
currentXFTPVersion = VersionXFTP 4
|
||||
|
||||
supportedFileServerVRange :: VersionRangeXFTP
|
||||
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
|
||||
@@ -124,14 +128,18 @@ data XFTPServerHandshake = XFTPServerHandshake
|
||||
-- | pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
authPubKey :: CertChainPubKey,
|
||||
-- | signed identity challenge from XFTPClientHello
|
||||
webIdentityProof :: Maybe C.ASignature
|
||||
webIdentityProof :: Maybe C.ASignature,
|
||||
-- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= fileStorageTimeXFTPVersion
|
||||
serverInfoBytes :: Maybe ByteString
|
||||
}
|
||||
|
||||
data XFTPClientHandshake = XFTPClientHandshake
|
||||
{ -- | agreed XFTP server protocol version
|
||||
xftpVersion :: VersionXFTP,
|
||||
-- | server identity - CA certificate fingerprint
|
||||
keyHash :: C.KeyHash
|
||||
keyHash :: C.KeyHash,
|
||||
-- | proof of the user entitlement bound to the session
|
||||
entitlementProof :: Maybe EntitlementProof
|
||||
}
|
||||
|
||||
instance Encoding XFTPClientHello where
|
||||
@@ -143,21 +151,33 @@ instance Encoding XFTPClientHello where
|
||||
pure XFTPClientHello {webChallenge}
|
||||
|
||||
instance Encoding XFTPClientHandshake where
|
||||
smpEncode XFTPClientHandshake {xftpVersion, keyHash} =
|
||||
smpEncode (xftpVersion, keyHash)
|
||||
smpEncode XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} =
|
||||
smpEncode (v, keyHash) <> ifHasEntitlement v (smpEncode entitlementProof) ""
|
||||
smpP = do
|
||||
(xftpVersion, keyHash) <- smpP
|
||||
(v, keyHash) <- smpP
|
||||
entitlementProof <- ifHasEntitlement v smpP (pure Nothing)
|
||||
Tail _compat <- smpP
|
||||
pure XFTPClientHandshake {xftpVersion, keyHash}
|
||||
pure XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof}
|
||||
|
||||
ifHasEntitlement :: VersionXFTP -> a -> a -> a
|
||||
ifHasEntitlement v a b = if v >= fileStorageTimeXFTPVersion then a else b
|
||||
|
||||
instance Encoding XFTPServerHandshake where
|
||||
smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} =
|
||||
smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof)
|
||||
smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes} =
|
||||
smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof) <> info
|
||||
where
|
||||
info = ifHasServerInfo (maxVersion xftpVersionRange) (smpEncode (Large <$> serverInfoBytes)) ""
|
||||
smpP = do
|
||||
(xftpVersionRange, sessionId, authPubKey) <- smpP
|
||||
webIdentityProof <- optional $ C.decodeSignature <$?> smpP
|
||||
-- decode the (length-prefixed) signature bytes deterministically: empty bytes decode to Nothing.
|
||||
-- (Must not use `optional`, which would backtrack and leave the bytes for the parsers that follow.)
|
||||
webIdentityProof <- C.decodeSignature <$?> smpP
|
||||
serverInfoBytes <- ifHasServerInfo (maxVersion xftpVersionRange) (unLarge <$$> smpP) (pure Nothing)
|
||||
Tail _compat <- smpP
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof}
|
||||
pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes}
|
||||
|
||||
ifHasServerInfo :: VersionXFTP -> a -> a -> a
|
||||
ifHasServerInfo v a b = if v >= fileStorageTimeXFTPVersion then a else b
|
||||
|
||||
sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
|
||||
sendEncFile h send = go
|
||||
|
||||
@@ -39,6 +39,7 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Word (Word32)
|
||||
import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (GrantedStorageTime (..))
|
||||
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
@@ -167,7 +168,8 @@ data SndFile = SndFile
|
||||
prefixPath :: Maybe FilePath,
|
||||
status :: SndFileStatus,
|
||||
deleted :: Bool,
|
||||
redirect :: Maybe RedirectFileInfo
|
||||
redirect :: Maybe RedirectFileInfo,
|
||||
storageHours :: Maybe Word32
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -225,7 +227,8 @@ data NewSndChunkReplica = NewSndChunkReplica
|
||||
{ server :: XFTPServer,
|
||||
replicaId :: ChunkReplicaId,
|
||||
replicaKey :: C.APrivateAuthKey,
|
||||
rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)]
|
||||
rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
|
||||
expiresAt :: Maybe GrantedStorageTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -237,7 +240,8 @@ data SndFileChunkReplica = SndFileChunkReplica
|
||||
rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
|
||||
replicaStatus :: SndFileReplicaStatus,
|
||||
delay :: Maybe Int64,
|
||||
retries :: Int
|
||||
retries :: Int,
|
||||
expiresAt :: Maybe GrantedStorageTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@@ -108,6 +108,7 @@ module Simplex.Messaging.Agent
|
||||
getConnectionServers,
|
||||
getConnectionRatchetAdHash,
|
||||
setProtocolServers,
|
||||
setUserEntitlement,
|
||||
checkUserServers,
|
||||
testProtocolServer,
|
||||
setNtfServers,
|
||||
@@ -187,7 +188,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Clock.System (systemToUTCTime)
|
||||
import Data.Traversable (mapAccumL)
|
||||
import Data.Word (Word16)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
@@ -211,6 +212,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
@@ -679,7 +681,7 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of
|
||||
SPSMP -> runSMPServerTest c nm userId srv
|
||||
SPXFTP -> maybe (Right Nothing) Left <$> runXFTPServerTest c nm userId srv
|
||||
SPXFTP -> runXFTPServerTest c nm userId srv
|
||||
SPNTF -> maybe (Right Nothing) Left <$> runNTFServerTest c nm userId srv
|
||||
|
||||
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
|
||||
@@ -773,8 +775,8 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
|
||||
{-# INLINE xftpDeleteRcvFiles #-}
|
||||
|
||||
-- | Send XFTP file
|
||||
xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
|
||||
xftpSendFile c = withAgentEnv c .:. xftpSendFile' c
|
||||
xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AE SndFileId
|
||||
xftpSendFile c = withAgentEnv c .:: xftpSendFile' c
|
||||
{-# INLINE xftpSendFile #-}
|
||||
|
||||
-- | Send XFTP file
|
||||
@@ -3049,6 +3051,17 @@ setProtocolServers c userId srvs = do
|
||||
checkUserServers "setProtocolServers" srvs
|
||||
atomically $ TM.insert userId (mkUserServers srvs) (userServers c)
|
||||
|
||||
-- | Change the entitlement credential presented to XFTP servers for the user.
|
||||
-- The credential is presented in the handshake, so the user's XFTP clients are closed to present the new one.
|
||||
setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()
|
||||
setUserEntitlement c userId cred_ = do
|
||||
changed <- atomically $ do
|
||||
prev_ <- TM.lookup userId $ userEntitlements c
|
||||
if prev_ == cred_
|
||||
then pure False
|
||||
else True <$ maybe (TM.delete userId) (TM.insert userId) cred_ (userEntitlements c)
|
||||
when changed $ closeUserXFTPClients c userId
|
||||
|
||||
checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO ()
|
||||
checkUserServers name srvs =
|
||||
unless (any (\ServerCfg {enabled} -> enabled) srvs) $
|
||||
|
||||
@@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Client
|
||||
reconnectServerClients,
|
||||
reconnectSMPServer,
|
||||
closeXFTPServerClient,
|
||||
closeUserXFTPClients,
|
||||
runSMPServerTest,
|
||||
runXFTPServerTest,
|
||||
runNTFServerTest,
|
||||
@@ -227,7 +228,7 @@ import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
|
||||
import Data.Time.Clock.System (getSystemTime)
|
||||
import Data.Word (Word16)
|
||||
import Data.Word (Word16, Word32)
|
||||
import qualified Data.X509.Validation as XV
|
||||
import Network.Socket (HostName)
|
||||
import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
|
||||
@@ -253,6 +254,8 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
|
||||
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..), BBSPublicKey)
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential, EntitlementProof, generateEntitlementProof)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Client
|
||||
@@ -354,6 +357,7 @@ data AgentClient = AgentClient
|
||||
ntfClients :: TMap NtfTransportSession NtfClientVar,
|
||||
xftpServers :: TMap UserId (UserServers 'PXFTP),
|
||||
xftpClients :: TMap XFTPTransportSession XFTPClientVar,
|
||||
userEntitlements :: TMap UserId EntitlementCredential,
|
||||
useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
|
||||
presetDomains :: [HostName],
|
||||
presetServers :: [SMPServer],
|
||||
@@ -511,7 +515,7 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
|
||||
|
||||
-- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
|
||||
newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient
|
||||
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do
|
||||
newAgentClient clientId InitialAgentServers {smp, ntf, xftp, entitlements, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do
|
||||
let cfg = config agentEnv
|
||||
qSize = tbqSize cfg
|
||||
proxySessTs <- newTVarIO =<< getCurrentTime
|
||||
@@ -527,6 +531,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
|
||||
ntfClients <- TM.emptyIO
|
||||
xftpServers <- newTVarIO $ M.map mkUserServers xftp
|
||||
xftpClients <- TM.emptyIO
|
||||
userEntitlements <- newTVarIO entitlements
|
||||
useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg)
|
||||
userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True
|
||||
userNetworkUpdated <- newTVarIO Nothing
|
||||
@@ -568,6 +573,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
|
||||
ntfClients,
|
||||
xftpServers,
|
||||
xftpClients,
|
||||
userEntitlements,
|
||||
useNetworkConfig,
|
||||
presetDomains,
|
||||
presetServers,
|
||||
@@ -878,7 +884,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, pr
|
||||
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
|
||||
|
||||
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
|
||||
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(_, srv, _) = do
|
||||
getXFTPServerClient c@AgentClient {active, xftpClients, userEntitlements, workerSeq, proxySessTs, presetDomains} tSess@(userId, srv, _) = do
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
withGetSessVar workerSeq tSess xftpClients ts (newProtocolClient c tSess xftpClients connectClient) (waitForProtocolClient c NRMBackground tSess xftpClients)
|
||||
@@ -886,12 +892,28 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs,
|
||||
connectClient :: XFTPClientVar -> AM XFTPClient
|
||||
connectClient v = do
|
||||
cfg <- asks $ xftpCfg . config
|
||||
keys <- asks $ entitlementKeys . config
|
||||
xftpNetworkConfig <- getNetworkConfig c
|
||||
ts <- readTVarIO proxySessTs
|
||||
liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (mkEntitlementProof keys) $
|
||||
clientDisconnected v
|
||||
|
||||
mkEntitlementProof :: Map Word16 BBSPublicKey -> SessionId -> IO (Maybe EntitlementProof)
|
||||
mkEntitlementProof keys sessId =
|
||||
ifM knownServer proof (pure Nothing)
|
||||
where
|
||||
-- the entitlement is presented only to the servers of this user, matched by key hash that TLS pins,
|
||||
-- so a file description of the sender cannot direct it to another server
|
||||
knownServer = maybe False (any (sameKeyHash . snd) . storageSrvs) <$> TM.lookupIO userId (xftpServers c)
|
||||
sameKeyHash (ProtoServerWithAuth srv' _) = srvKeyHash srv' == srvKeyHash srv
|
||||
srvKeyHash (ProtocolServer _ _ _ kh) = kh
|
||||
proof =
|
||||
TM.lookupIO userId userEntitlements $>>= \cred ->
|
||||
generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case
|
||||
Right p -> pure $ Just p
|
||||
Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)
|
||||
|
||||
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
|
||||
clientDisconnected v client = do
|
||||
atomically $ removeSessVar v tSess xftpClients
|
||||
@@ -1037,6 +1059,13 @@ reconnectSMPServer c userId srv = do
|
||||
| userId == userId' && srv == srv' = (v :)
|
||||
| otherwise = id
|
||||
|
||||
closeUserXFTPClients :: AgentClient -> UserId -> IO ()
|
||||
closeUserXFTPClients c userId = do
|
||||
vs <- atomically $ stateTVar (xftpClients c) $ \cs ->
|
||||
let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs
|
||||
in (M.elems userCs, cs')
|
||||
mapM_ (forkIO . closeClient_ c) vs
|
||||
|
||||
closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
|
||||
closeClient c clientSel tSess =
|
||||
atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
|
||||
@@ -1326,7 +1355,7 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
|
||||
testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
|
||||
testErr step = ProtocolTestFailure step . protocolClientError SMP addr
|
||||
|
||||
runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do
|
||||
cfg <- asks $ xftpCfg . config
|
||||
g <- asks random
|
||||
@@ -1337,7 +1366,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
|
||||
liftIO $ do
|
||||
let tSess = (userId, srv, Nothing)
|
||||
ts <- readTVarIO $ proxySessTs c
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure ()) >>= \case
|
||||
X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case
|
||||
Right xftp -> withTestChunk filePath $ do
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -1345,15 +1374,15 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
|
||||
r <- runExceptT $ do
|
||||
(sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
|
||||
(sId, [rId], _) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth Nothing
|
||||
liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
|
||||
liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
|
||||
rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
|
||||
unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
|
||||
liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
|
||||
ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure (Just $ testErr TSConnect e)
|
||||
pure $ r >> maybe (Left (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const $ Right $ serverInfo (X.thParams xftp)) ok
|
||||
Left e -> pure $ Left (testErr TSConnect e)
|
||||
where
|
||||
addr = B.unpack $ strEncode srv
|
||||
testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
|
||||
@@ -2186,16 +2215,17 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se
|
||||
g <- asks random
|
||||
withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec
|
||||
|
||||
agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica
|
||||
agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
|
||||
agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica
|
||||
agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageHours = do
|
||||
rKeys <- xftpRcvKeys n
|
||||
(sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
|
||||
let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
|
||||
logServer "-->" c srv NoEntity "FNEW"
|
||||
tSess <- mkTransportSession c userId srv chunkDigest
|
||||
(sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
|
||||
(sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp ->
|
||||
X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageHours
|
||||
logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
|
||||
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
|
||||
pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt}
|
||||
|
||||
agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
|
||||
agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -309,7 +309,7 @@ import Network.Socket (ServiceName)
|
||||
import qualified Network.TLS as TLS
|
||||
import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Types
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
|
||||
@@ -3424,13 +3424,13 @@ getRcvFilesExpired db ttl = do
|
||||
|]
|
||||
(Only cutoffTs)
|
||||
|
||||
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId)
|
||||
createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ =
|
||||
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Word32 -> IO (Either StoreError SndFileId)
|
||||
createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageHours =
|
||||
createWithRandomId db gVar $ \sndFileEntityId ->
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_))
|
||||
"INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, storageHours))
|
||||
where
|
||||
(redirectSize_, redirectDigest_) =
|
||||
case redirect_ of
|
||||
@@ -3466,7 +3466,7 @@ getSndFile db sndFileId = runExceptT $ do
|
||||
DB.query
|
||||
db
|
||||
( [sql|
|
||||
SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest
|
||||
SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, storage_time
|
||||
FROM snd_files
|
||||
WHERE snd_file_id = ?
|
||||
|]
|
||||
@@ -3476,12 +3476,12 @@ getSndFile db sndFileId = runExceptT $ do
|
||||
)
|
||||
(Only sndFileId)
|
||||
where
|
||||
toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile
|
||||
toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) =
|
||||
toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe Word32) -> SndFile
|
||||
toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageHours)) =
|
||||
let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
|
||||
srcFile = CryptoFile srcPath cfArgs
|
||||
redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_
|
||||
in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []}
|
||||
in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageHours, chunks = []}
|
||||
getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
|
||||
getChunks sndFileEntityId userId numRecipients filePrefixPath = do
|
||||
chunks <-
|
||||
@@ -3510,7 +3510,7 @@ getSndFile db sndFileId = runExceptT $ do
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries,
|
||||
r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at,
|
||||
s.xftp_host, s.xftp_port, s.xftp_key_hash
|
||||
FROM snd_file_chunk_replicas r
|
||||
JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
|
||||
@@ -3521,10 +3521,10 @@ getSndFile db sndFileId = runExceptT $ do
|
||||
rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
|
||||
pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
|
||||
where
|
||||
toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
|
||||
toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) =
|
||||
toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
|
||||
toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec, host, port, keyHash) =
|
||||
let server = XFTPServer host port keyHash
|
||||
in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}
|
||||
in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}
|
||||
|
||||
getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)]
|
||||
getChunkReplicaRecipients_ db replicaId =
|
||||
@@ -3605,16 +3605,16 @@ createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> I
|
||||
createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId
|
||||
|
||||
createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO ()
|
||||
createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
|
||||
createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys, expiresAt} = do
|
||||
srvId <- createXFTPServer_ db server
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO snd_file_chunk_replicas
|
||||
(snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
(snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status, replica_expires_at)
|
||||
VALUES (?,?,?,?,?,?,?)
|
||||
|]
|
||||
(sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated)
|
||||
(sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated, epochSeconds <$> expiresAt)
|
||||
rId <- insertedRowId db
|
||||
forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do
|
||||
DB.execute
|
||||
@@ -3660,7 +3660,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
|
||||
SELECT
|
||||
f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path,
|
||||
c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest,
|
||||
r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries
|
||||
r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at
|
||||
FROM snd_file_chunk_replicas r
|
||||
JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
|
||||
JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
|
||||
@@ -3674,8 +3674,8 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
|
||||
pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
|
||||
pure (chunk {replicas = replicas'} :: SndFileChunk)
|
||||
where
|
||||
toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
|
||||
toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
|
||||
toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64)) -> SndFileChunk
|
||||
toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec)) =
|
||||
let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
|
||||
in SndFileChunk
|
||||
{ sndFileId,
|
||||
@@ -3687,7 +3687,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
|
||||
chunkSpec,
|
||||
digest,
|
||||
filePrefixPath,
|
||||
replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}]
|
||||
replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}]
|
||||
}
|
||||
|
||||
updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()
|
||||
|
||||
@@ -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
|
||||
|
||||
+21
@@ -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;
|
||||
|]
|
||||
@@ -682,7 +682,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_file_chunk_replicas (
|
||||
delay bigint,
|
||||
retries bigint DEFAULT 0 NOT NULL,
|
||||
created_at timestamp with time zone DEFAULT now() NOT NULL,
|
||||
updated_at timestamp with time zone DEFAULT now() NOT NULL
|
||||
updated_at timestamp with time zone DEFAULT now() NOT NULL,
|
||||
replica_expires_at bigint
|
||||
);
|
||||
|
||||
|
||||
@@ -741,7 +742,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_files (
|
||||
src_file_nonce bytea,
|
||||
failed smallint DEFAULT 0,
|
||||
redirect_size bigint,
|
||||
redirect_digest bytea
|
||||
redirect_digest bytea,
|
||||
storage_time bigint
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
+20
@@ -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;
|
||||
|]
|
||||
@@ -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,
|
||||
|
||||
@@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.BBS
|
||||
BBSProof (..),
|
||||
BBSHeader (..),
|
||||
BBSPresHeader (..),
|
||||
FixedBS (..),
|
||||
bbsKeyGen,
|
||||
bbsPublicKey,
|
||||
bbsSign,
|
||||
@@ -33,7 +34,9 @@ import Data.Proxy (Proxy (..))
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
|
||||
import Simplex.Messaging.Encoding (Encoding (..), Large (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
-- Note: the data constructors below are unchecked escape hatches for trusted,
|
||||
@@ -71,8 +74,8 @@ newtype BBSPresHeader = BBSPresHeader ByteString
|
||||
deriving (ToJSON, FromJSON) via (StrJSON "BBSPresHeader" BBSPresHeader)
|
||||
|
||||
-- | A ByteString validated to be exactly @n@ bytes when parsed via StrEncoding
|
||||
-- (and the JSON derived from it). Local to BBS, where every key/signature is a
|
||||
-- fixed size; @name@ appears in the decode error only.
|
||||
-- (and the JSON derived from it), for keys and signatures of a fixed size;
|
||||
-- @name@ appears in the decode error only.
|
||||
newtype FixedBS (name :: Symbol) (n :: Nat) = FixedBS ByteString
|
||||
|
||||
instance forall name n. (KnownSymbol name, KnownNat n) => StrEncoding (FixedBS name n) where
|
||||
@@ -97,14 +100,20 @@ bbsProofLen :: Int -> Int
|
||||
bbsProofLen numUndisclosed = bbsProofBaseLen + numUndisclosed * bbsProofUdElemLen
|
||||
|
||||
-- | A proof is @bbsProofBaseLen + 32 * numUndisclosed@ bytes; reject anything else.
|
||||
mkBBSProof :: ByteString -> Either String BBSProof
|
||||
mkBBSProof bs
|
||||
| len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 = Right $ BBSProof bs
|
||||
| otherwise = Left $ "BBS: invalid proof length " <> show len
|
||||
where
|
||||
len = B.length bs
|
||||
|
||||
instance StrEncoding BBSProof where
|
||||
strEncode (BBSProof bs) = strEncode bs
|
||||
strP = do
|
||||
bs <- base64urlP
|
||||
let len = B.length bs
|
||||
if len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0
|
||||
then pure (BBSProof bs)
|
||||
else fail $ "BBS: invalid proof length " <> show len
|
||||
strP = mkBBSProof <$?> base64urlP
|
||||
|
||||
instance Encoding BBSProof where
|
||||
smpEncode (BBSProof p) = smpEncode (Large p)
|
||||
smpP = mkBBSProof . unLarge <$?> smpP
|
||||
|
||||
-- FFI
|
||||
|
||||
|
||||
@@ -0,0 +1,151 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.Entitlement
|
||||
( Entitlement (..),
|
||||
EntitlementCredential (..),
|
||||
EntitlementProof (..),
|
||||
EntitlementVerification (..),
|
||||
MasterKey (..),
|
||||
randomMasterKey,
|
||||
entitlementBBSHeader,
|
||||
entitlementIssuerKeys,
|
||||
signEntitlement,
|
||||
verifyCredential,
|
||||
generateEntitlementProof,
|
||||
verifyEntitlement,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as JQ
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Either (fromRight)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Word (Word16)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON)
|
||||
import Simplex.Messaging.Util ((<$$>))
|
||||
|
||||
newtype MasterKey = MasterKey ByteString
|
||||
deriving newtype (Eq, Show)
|
||||
deriving (StrEncoding) via (FixedBS "MasterKey" 32)
|
||||
deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey)
|
||||
|
||||
data Entitlement = Entitlement
|
||||
{ expiresAt :: UTCTime,
|
||||
entitlementName :: Text,
|
||||
extraInfo :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data EntitlementCredential = EntitlementCredential
|
||||
{ issuerKeyIdx :: Word16,
|
||||
masterKey :: MasterKey,
|
||||
entitlement :: Entitlement,
|
||||
issuerSignature :: BBSSignature
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data EntitlementProof = EntitlementProof
|
||||
{ issuerKeyIdx :: Word16,
|
||||
entitlement :: Entitlement,
|
||||
entProof :: BBSProof
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding Entitlement where
|
||||
smpEncode Entitlement {expiresAt, entitlementName, extraInfo} =
|
||||
smpEncode (strEncode expiresAt, entitlementName, Large $ encodeUtf8 extraInfo)
|
||||
smpP = do
|
||||
(expBs, entitlementName, Large extraBs) <- smpP
|
||||
expiresAt <- either fail pure $ strDecode (expBs :: ByteString)
|
||||
extraInfo <- either (fail . show) pure $ decodeUtf8' extraBs
|
||||
pure Entitlement {expiresAt, entitlementName, extraInfo}
|
||||
|
||||
instance Encoding EntitlementProof where
|
||||
smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} =
|
||||
smpEncode (issuerKeyIdx, entProof, entitlement)
|
||||
smpP = do
|
||||
(issuerKeyIdx, entProof, entitlement) <- smpP
|
||||
pure EntitlementProof {issuerKeyIdx, entProof, entitlement}
|
||||
|
||||
entitlementBBSHeader :: BBSHeader
|
||||
entitlementBBSHeader = BBSHeader "SimpleX badges v1"
|
||||
|
||||
entitlementMessageCount :: Int
|
||||
entitlementMessageCount = 4
|
||||
|
||||
entitlementDisclosedIndexes :: [Int]
|
||||
entitlementDisclosedIndexes = [1, 2, 3]
|
||||
|
||||
entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
|
||||
entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent
|
||||
|
||||
disclosedMessages :: Entitlement -> [ByteString]
|
||||
disclosedMessages Entitlement {expiresAt, entitlementName, extraInfo} =
|
||||
[strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo]
|
||||
|
||||
randomMasterKey :: TVar ChaChaDRG -> STM MasterKey
|
||||
randomMasterKey g = MasterKey <$> C.randomBytes 32 g
|
||||
|
||||
signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential)
|
||||
signEntitlement sk keyIdx mk ent =
|
||||
EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent)
|
||||
|
||||
verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool
|
||||
verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} =
|
||||
bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement)
|
||||
|
||||
generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
|
||||
generateEntitlementProof keys EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
|
||||
case M.lookup issuerKeyIdx keys of
|
||||
Nothing -> pure $ Left $ "no issuer key " <> show issuerKeyIdx
|
||||
Just pk -> EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
|
||||
|
||||
verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification
|
||||
verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} =
|
||||
case M.lookup issuerKeyIdx keys of
|
||||
Nothing -> pure EVUnknownIssuer
|
||||
Just pk ->
|
||||
(\valid -> if valid then EVValid else EVInvalid)
|
||||
<$> bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
|
||||
|
||||
entitlementIssuerKeys :: Map Word16 BBSPublicKey
|
||||
entitlementIssuerKeys =
|
||||
M.fromList
|
||||
[ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"),
|
||||
(2, key "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"),
|
||||
(3, key "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"),
|
||||
(4, key "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"),
|
||||
(5, key "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"),
|
||||
(6, key "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"),
|
||||
(7, key "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
|
||||
(8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
|
||||
]
|
||||
where
|
||||
key = fromRight (error "bad base64 in BBSPublicKey") . strDecode . B.pack
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''Entitlement)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''EntitlementCredential)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''EntitlementProof)
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -6,14 +6,25 @@ module Simplex.Messaging.Server.Main.GitCommit
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (addDependentFile)
|
||||
import System.Process
|
||||
import Control.Exception
|
||||
import Control.Monad (filterM)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Exit
|
||||
import System.FilePath ((</>))
|
||||
|
||||
gitCommit :: Q Exp
|
||||
gitCommit = stringE . commit =<< runIO (try $ readProcessWithExitCode "git" ["rev-parse", "HEAD"] "")
|
||||
gitCommit =
|
||||
runIO gitHead >>= \case
|
||||
Right (ExitSuccess, out, _)
|
||||
| [commit, gitDir] <- lines out -> do
|
||||
-- without these dependencies GHC recompilation check would not know that the commit changed.
|
||||
-- HEAD reflog is updated on any HEAD change and, unlike branch ref files, git gc cannot remove it
|
||||
-- mid-build; it is absent when reflogs are disabled, and addDependentFile fails on a missing file
|
||||
mapM_ addDependentFile =<< runIO (filterM doesFileExist [gitDir </> "HEAD", gitDir </> "logs" </> "HEAD"])
|
||||
stringE commit
|
||||
_ -> stringE ""
|
||||
where
|
||||
commit :: Either SomeException (ExitCode, String, String) -> String
|
||||
commit = \case
|
||||
Right (ExitSuccess, out, _) -> take 40 out
|
||||
_ -> ""
|
||||
gitHead :: IO (Either SomeException (ExitCode, String, String))
|
||||
gitHead = try $ readProcessWithExitCode "git" ["rev-parse", "HEAD", "--git-dir"] ""
|
||||
|
||||
@@ -85,6 +85,8 @@ module Simplex.Messaging.Transport
|
||||
THandle (..),
|
||||
THandleParams (..),
|
||||
THandleAuth (..),
|
||||
SessionEntitlement (..),
|
||||
EntitlementConfig (..),
|
||||
CertChainPubKey (..),
|
||||
ServiceCredentials (..),
|
||||
THClientService' (..),
|
||||
@@ -120,6 +122,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Default (def)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
import Data.Tuple (swap)
|
||||
import Data.Typeable (Typeable)
|
||||
@@ -137,6 +140,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
|
||||
import Simplex.Messaging.Server.Information
|
||||
import Simplex.Messaging.SystemTime (SystemSeconds)
|
||||
import Simplex.Messaging.Transport.Buffer
|
||||
import Simplex.Messaging.Transport.Shared
|
||||
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>))
|
||||
@@ -490,10 +494,15 @@ data THandleAuth (p :: TransportPeer) where
|
||||
THAuthServer ::
|
||||
{ serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
|
||||
peerClientService :: Maybe THPeerClientService,
|
||||
peerEntitlement :: Maybe SessionEntitlement, -- verified in the handshake, applies to the whole session
|
||||
sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
|
||||
} ->
|
||||
THandleAuth 'TServer
|
||||
|
||||
data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}
|
||||
|
||||
newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64}
|
||||
|
||||
type THClientService = THClientService' C.PrivateKeyEd25519
|
||||
|
||||
type THPeerClientService = THClientService' C.PublicKeyEd25519
|
||||
@@ -808,7 +817,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey
|
||||
|
||||
smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer)
|
||||
smpTHandleServer th v vr pk k_ proxyServer peerClientService = do
|
||||
let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_}
|
||||
let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, peerEntitlement = Nothing, sessSecret' = (`C.dh'` pk) <$!> k_}
|
||||
be <- blockEncryption th proxyServer thAuth
|
||||
pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing
|
||||
|
||||
|
||||
@@ -54,6 +54,7 @@ module AgentTests.FunctionalAPITests
|
||||
pattern SENT,
|
||||
agentCfgVPrevPQ,
|
||||
agentCfgV7,
|
||||
testServerInformation,
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -63,6 +63,7 @@ initServers =
|
||||
{ smp = M.fromList [(1, testSMPServers)],
|
||||
ntf = [testNtfServer],
|
||||
xftp = userServers [testXFTPServer],
|
||||
entitlements = M.empty,
|
||||
netCfg = defaultNetworkConfig,
|
||||
useServices = M.empty,
|
||||
presetDomains = [],
|
||||
|
||||
@@ -7,14 +7,18 @@
|
||||
module CoreTests.CryptoTests (cryptoTests) where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Monad.Except
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Either (isLeft, isRight)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time.Calendar (fromGregorian)
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import qualified Data.Text.Lazy.Encoding as LE
|
||||
import Data.Type.Equality
|
||||
@@ -25,6 +29,7 @@ import qualified SMPClient
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Crypto.BBS
|
||||
import Simplex.Messaging.Crypto.Entitlement
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
|
||||
import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode)
|
||||
@@ -119,6 +124,9 @@ cryptoTests = do
|
||||
it "should produce unlinkable proofs" testBBSUnlinkable
|
||||
it "should produce proof of expected size" testBBSProofSize
|
||||
it "should roundtrip JSON and reject wrong-length input" testBBSJSON
|
||||
describe "Entitlement" $ do
|
||||
it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip
|
||||
it "should decode all issuer keys" testEntitlementIssuerKeys
|
||||
|
||||
instance Eq C.APublicKey where
|
||||
C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of
|
||||
@@ -444,3 +452,26 @@ testBBSJSON = do
|
||||
-- FromJSON must reject wrong-length input (regression: StrJSON length validation)
|
||||
(J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing
|
||||
(J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing
|
||||
|
||||
testEntitlementRoundtrip :: IO ()
|
||||
testEntitlementRoundtrip = do
|
||||
Right (pk, sk) <- bbsKeyGen
|
||||
let keys = M.singleton 1 pk
|
||||
mk = MasterKey (B.replicate 32 '\7')
|
||||
ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""}
|
||||
ph = BBSPresHeader "session-id"
|
||||
Right cred <- signEntitlement sk 1 mk ent
|
||||
verifyCredential pk cred `shouldReturn` True
|
||||
Right proof <- generateEntitlementProof keys cred ph
|
||||
verifyEntitlement keys ph proof `shouldReturn` EVValid
|
||||
-- a different presentation header does not verify (session binding)
|
||||
verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` EVInvalid
|
||||
-- an unknown issuer key index is distinguished from an invalid proof
|
||||
verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` EVUnknownIssuer
|
||||
-- the protocol encoding of the proof roundtrips
|
||||
smpDecode (smpEncode proof) `shouldBe` Right proof
|
||||
|
||||
testEntitlementIssuerKeys :: IO ()
|
||||
testEntitlementIssuerKeys = do
|
||||
mapM_ evaluate entitlementIssuerKeys
|
||||
M.size entitlementIssuerKeys `shouldBe` 8
|
||||
|
||||
@@ -20,9 +20,13 @@ import qualified Data.Map.Strict as M
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
import SMPClient
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..))
|
||||
import Simplex.FileTransfer.Server.Store (FileRec (..), FileRecipient (..), FileStoreClass (..), RoundedFileTime, STMFileStore (..))
|
||||
import Simplex.FileTransfer.Server.StoreLog (FileStoreLogRecord (..), readWriteFileStore)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Protocol.Types (ClientNotice (..))
|
||||
import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
|
||||
import Simplex.Messaging.Server.MsgStore.Journal
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
@@ -191,3 +195,100 @@ testSMPStoreLog testSuite tests =
|
||||
compacted' `shouldBe` compacted
|
||||
storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec)
|
||||
storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec))
|
||||
|
||||
type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
|
||||
|
||||
type XFTPStoreLogTestCase = StoreLogTestCase FileStoreLogRecord (M.Map SenderId FileRecState)
|
||||
|
||||
deriving instance Eq FileInfo
|
||||
|
||||
deriving instance Eq FileRecipient
|
||||
|
||||
deriving instance Eq FileStoreLogRecord
|
||||
|
||||
testFileStoreLogFile :: FilePath
|
||||
testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
|
||||
|
||||
fileExpirationTests :: Spec
|
||||
fileExpirationTests =
|
||||
describe "XFTP file expiration" $
|
||||
it "expires by stored expiration and by creation time" testExpiredFiles
|
||||
|
||||
testExpiredFiles :: Expectation
|
||||
testExpiredFiles = do
|
||||
st <- newFileStore () :: IO STMFileStore
|
||||
g <- C.newRandom
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
|
||||
created = RoundedSystemTime 100000
|
||||
addFile st (EntityId "expired_stored__") file created (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "stored_ahead____") file created (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "legacy_expired__") file created Nothing EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "legacy_in_grace_") file (RoundedSystemTime 297000) Nothing EntityActive `shouldReturn` Right ()
|
||||
expired <- expiredFiles st (RoundedSystemTime 500000) 300000 100
|
||||
map (\(sId, _, _) -> sId) expired `shouldMatchList` [EntityId "expired_stored__", EntityId "legacy_expired__"]
|
||||
|
||||
fileStoreLogTests :: Spec
|
||||
fileStoreLogTests = do
|
||||
g <- runIO C.newRandom
|
||||
(sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g
|
||||
let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
|
||||
createdAt = RoundedSystemTime 1600000000
|
||||
expiresAt = RoundedSystemTime 1600172800
|
||||
blocked = BlockingInfo {reason = BRSpam, notice = Nothing}
|
||||
blockedWithNotice = BlockingInfo {reason = BRContent, notice = Just ClientNotice {ttl = Just 86400}}
|
||||
testXFTPStoreLog
|
||||
"XFTP server store log"
|
||||
[ SLTC
|
||||
{ name = "create file",
|
||||
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive],
|
||||
compacted = [AddFile sId file createdAt (Just expiresAt) EntityActive],
|
||||
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityActive))]
|
||||
},
|
||||
SLTC
|
||||
{ name = "create file without expiration",
|
||||
saved = [AddFile sId file createdAt Nothing EntityActive],
|
||||
compacted = [AddFile sId file createdAt Nothing EntityActive],
|
||||
state = M.fromList [(sId, (file, createdAt, Nothing, EntityActive))]
|
||||
},
|
||||
SLTC
|
||||
{ name = "create and block file",
|
||||
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blocked],
|
||||
compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blocked)],
|
||||
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blocked))]
|
||||
},
|
||||
SLTC
|
||||
{ name = "create and block file with notice",
|
||||
saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice],
|
||||
compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)],
|
||||
state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))]
|
||||
},
|
||||
SLTC
|
||||
{ name = "block file without expiration",
|
||||
saved = [AddFile sId file createdAt Nothing EntityActive, BlockFile sId blockedWithNotice],
|
||||
compacted = [AddFile sId file createdAt Nothing (EntityBlocked blockedWithNotice)],
|
||||
state = M.fromList [(sId, (file, createdAt, Nothing, EntityBlocked blockedWithNotice))]
|
||||
}
|
||||
]
|
||||
|
||||
testXFTPStoreLog :: String -> [XFTPStoreLogTestCase] -> Spec
|
||||
testXFTPStoreLog testSuite tests =
|
||||
describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
|
||||
l <- openWriteStoreLog False testFileStoreLogFile
|
||||
mapM_ (writeStoreLogRecord l) saved
|
||||
closeStoreLog l
|
||||
replicateM_ 3 $ testReadWrite t
|
||||
where
|
||||
testReadWrite SLTC {compacted, state} = do
|
||||
st <- newFileStore () :: IO STMFileStore
|
||||
l <- readWriteFileStore testFileStoreLogFile st
|
||||
storeState st `shouldReturn` state
|
||||
closeStoreLog l
|
||||
([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile
|
||||
compacted' `shouldBe` compacted
|
||||
storeState :: STMFileStore -> IO (M.Map SenderId FileRecState)
|
||||
storeState st = readTVarIO (files st) >>= mapM fileState
|
||||
fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do
|
||||
status <- readTVarIO fileStatus
|
||||
pure (fileInfo, createdAt, expiresAt, status)
|
||||
|
||||
@@ -37,6 +37,7 @@ xftpStoreTests = do
|
||||
it "should block file and update status" testBlockFile
|
||||
it "should ack file reception" testAckFile
|
||||
it "should return expired files with limit" testExpiredFiles
|
||||
it "should expire files by stored expiration" testExpiredFilesStoredExpiration
|
||||
it "should compute committed used storage and file count" testStorageAndCount
|
||||
|
||||
xftpMigrationTests :: Spec
|
||||
@@ -68,6 +69,9 @@ testFileInfo sndKey =
|
||||
testCreatedAt :: RoundedFileTime
|
||||
testCreatedAt = RoundedSystemTime 1000000
|
||||
|
||||
testExpiresAt :: RoundedFileTime
|
||||
testExpiresAt = RoundedSystemTime 2000000
|
||||
|
||||
-- Tests
|
||||
|
||||
testAddGetFileSender :: Expectation
|
||||
@@ -75,7 +79,7 @@ testAddGetFileSender = withPgStore $ \st -> do
|
||||
g <- C.newRandom
|
||||
(sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sk
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
result <- getFile st SFSender testSenderId
|
||||
case result of
|
||||
Right (FileRec {senderId, fileInfo = fi, createdAt}, key) -> do
|
||||
@@ -92,7 +96,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
|
||||
result <- getFile st SFRecipient testRecipientId
|
||||
case result of
|
||||
@@ -106,8 +110,8 @@ testDuplicateFile = withPgStore $ \st -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Left DUPLICATE_
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_
|
||||
|
||||
testGetNonexistent :: Expectation
|
||||
testGetNonexistent = withPgStore $ \st -> do
|
||||
@@ -119,7 +123,7 @@ testSetFilePath = withPgStore $ \st -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
setFilePath st testSenderId "/tmp/test_file" `shouldReturn` Right ()
|
||||
-- Second setFilePath should fail (file_path IS NULL guard)
|
||||
setFilePath st testSenderId "/tmp/other_file" `shouldReturn` Left AUTH
|
||||
@@ -135,7 +139,7 @@ testDuplicateRecipient = withPgStore $ \st -> do
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
|
||||
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_
|
||||
|
||||
@@ -145,7 +149,7 @@ testDeleteFileCascade = withPgStore $ \st -> do
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
|
||||
deleteFile st testSenderId `shouldReturn` Right ()
|
||||
-- File and recipient should both be gone
|
||||
@@ -157,7 +161,7 @@ testBlockFile = withPgStore $ \st -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
let blockInfo = BlockingInfo {reason = BRContent, notice = Nothing}
|
||||
blockFile st testSenderId blockInfo False `shouldReturn` Right ()
|
||||
result <- getFile st SFSender testSenderId
|
||||
@@ -171,7 +175,7 @@ testAckFile = withPgStore $ \st -> do
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
|
||||
ackFile st testRecipientId `shouldReturn` Right ()
|
||||
-- Recipient gone, but file still exists
|
||||
@@ -189,11 +193,11 @@ testExpiredFiles = withPgStore $ \st -> do
|
||||
oldTime = RoundedSystemTime 100000
|
||||
newTime = RoundedSystemTime 999999999
|
||||
-- Add old and new files
|
||||
addFile st (EntityId "old_file________") fileInfo oldTime EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "old_file________") fileInfo oldTime Nothing EntityActive `shouldReturn` Right ()
|
||||
void $ setFilePath st (EntityId "old_file________") "/tmp/old"
|
||||
addFile st (EntityId "new_file________") fileInfo newTime EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right ()
|
||||
-- Query expired with cutoff that only catches old file
|
||||
expired <- expiredFiles st 500000 100
|
||||
expired <- expiredFiles st (RoundedSystemTime 500000) 500000 100
|
||||
length expired `shouldBe` 1
|
||||
case expired of
|
||||
[(sId, path, sz)] -> do
|
||||
@@ -202,6 +206,18 @@ testExpiredFiles = withPgStore $ \st -> do
|
||||
sz `shouldBe` 128000
|
||||
_ -> expectationFailure "expected 1 expired file"
|
||||
|
||||
testExpiredFilesStoredExpiration :: Expectation
|
||||
testExpiredFilesStoredExpiration = withPgStore $ \st -> do
|
||||
g <- C.newRandom
|
||||
(sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let fileInfo = testFileInfo sndKey
|
||||
oldTime = RoundedSystemTime 100000
|
||||
-- both files are created before the cutoff, the stored expiration decides
|
||||
addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
|
||||
addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
|
||||
expired <- expiredFiles st (RoundedSystemTime 500000) 0 100
|
||||
map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
|
||||
|
||||
testStorageAndCount :: Expectation
|
||||
testStorageAndCount = withPgStore $ \st -> do
|
||||
testStorageAndCountForStore st
|
||||
@@ -222,8 +238,8 @@ testStorageAndCountForStore st = do
|
||||
fileInfoB = fileInfoA {size = 64000}
|
||||
fileA = EntityId "file_a__________"
|
||||
fileB = EntityId "file_b__________"
|
||||
addFile st fileA fileInfoA testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st fileB fileInfoB testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile st fileA fileInfoA testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
addFile st fileB fileInfoB testCreatedAt Nothing EntityActive `shouldReturn` Right ()
|
||||
getFileCount st `shouldReturn` 2
|
||||
getUsedStorage st `shouldReturn` 0
|
||||
setFilePath st fileA "/tmp/file_a" `shouldReturn` Right ()
|
||||
@@ -248,11 +264,11 @@ testMigrationRoundTrip = do
|
||||
sId1 = EntityId "migration_file_1"
|
||||
sId2 = EntityId "migration_file_2"
|
||||
rId1 = EntityId "migration_rcp_1_"
|
||||
addFile stmStore sId1 fileInfo1 testCreatedAt EntityActive `shouldReturn` Right ()
|
||||
addFile stmStore sId1 fileInfo1 testCreatedAt (Just testExpiresAt) EntityActive `shouldReturn` Right ()
|
||||
void $ setFilePath stmStore sId1 "/tmp/file1"
|
||||
addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right ()
|
||||
let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing}
|
||||
addFile stmStore sId2 fileInfo2 testCreatedAt (EntityBlocked testBlockInfo) `shouldReturn` Right ()
|
||||
addFile stmStore sId2 fileInfo2 testCreatedAt Nothing (EntityBlocked testBlockInfo) `shouldReturn` Right ()
|
||||
-- 2. Write to StoreLog
|
||||
sl <- openWriteStoreLog False storeLogPath
|
||||
writeFileStore sl stmStore
|
||||
@@ -271,9 +287,10 @@ testMigrationRoundTrip = do
|
||||
-- Verify file 1
|
||||
result1 <- getFile stmStore2 SFSender sId1
|
||||
case result1 of
|
||||
Right (FileRec {fileInfo = fi, filePath, fileStatus}, _) -> do
|
||||
Right (FileRec {fileInfo = fi, filePath, expiresAt, fileStatus}, _) -> do
|
||||
size fi `shouldBe` 128000
|
||||
readTVarIO filePath `shouldReturn` Just "/tmp/file1"
|
||||
expiresAt `shouldBe` Just testExpiresAt
|
||||
readTVarIO fileStatus `shouldReturn` EntityActive
|
||||
Left e -> expectationFailure $ "getFile sId1 failed: " <> show e
|
||||
-- Verify recipient
|
||||
|
||||
@@ -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 = [],
|
||||
|
||||
@@ -97,6 +97,8 @@ main = do
|
||||
#else
|
||||
describe "Store log tests" storeLogTests
|
||||
#endif
|
||||
describe "XFTP store log tests" fileStoreLogTests
|
||||
fileExpirationTests
|
||||
describe "TSessionSubs tests" tSessionSubsTests
|
||||
describe "Util tests" utilTests
|
||||
describe "Names resolver tests" smpNamesTests
|
||||
|
||||
+60
-9
@@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -10,7 +11,7 @@
|
||||
|
||||
module XFTPAgent where
|
||||
|
||||
import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet, withAgent, testServerInformation)
|
||||
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
@@ -20,28 +21,37 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, isSuffixOf)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Time.Clock.System (getSystemTime, systemSeconds)
|
||||
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2, testDB3)
|
||||
import SMPClient (xit'')
|
||||
import Simplex.FileTransfer.Client (XFTPClientConfig (..))
|
||||
import Simplex.FileTransfer.Description (FileChunk (..), FileDescription (..), FileDescriptionURI (..), ValidFileDescription, fileDescriptionURI, kb, mb, qrSizeLimit, pattern ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..))
|
||||
import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..), defaultFileExpiration)
|
||||
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers)
|
||||
import qualified Simplex.Messaging.Agent as XA
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), noAuthSrv)
|
||||
import qualified Simplex.Messaging.Agent.Env.SQLite as AEnv
|
||||
import Simplex.Messaging.Agent.Protocol hiding (SFDONE)
|
||||
import qualified Simplex.Messaging.Agent.Protocol as A
|
||||
import Simplex.Messaging.Client (pattern NRMInteractive)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS (bbsKeyGen)
|
||||
import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), signEntitlement)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import Simplex.Messaging.Transport (EntitlementConfig (..))
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
|
||||
import System.FilePath ((</>))
|
||||
@@ -56,6 +66,9 @@ import Fixtures
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
|
||||
#endif
|
||||
|
||||
pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile
|
||||
pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _
|
||||
|
||||
xftpAgentTests :: SpecWith AFStoreType
|
||||
xftpAgentTests =
|
||||
around_ testBracket
|
||||
@@ -71,6 +84,7 @@ xftpAgentTests =
|
||||
it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
|
||||
it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect
|
||||
it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect
|
||||
it "should extend storage time with an entitlement proof and report the granted expiry" $ \_ -> testXFTPAgentEntitlement
|
||||
describe "sending and receiving with version negotiation" $ beforeWith (const (pure ())) testXFTPAgentSendReceiveMatrix
|
||||
it "should resume receiving file after restart" $ \_ -> testXFTPAgentReceiveRestore
|
||||
it "should cleanup rcv tmp path after permanent error" $ \_ -> testXFTPAgentReceiveCleanup
|
||||
@@ -83,7 +97,7 @@ xftpAgentTests =
|
||||
it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer
|
||||
it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
|
||||
describe "XFTP server test via agent API" $ do
|
||||
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right Nothing
|
||||
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right (Just (Right testServerInformation))
|
||||
let srv1 = testXFTPServer2 {keyHash = "1234"}
|
||||
it "should fail with incorrect fingerprint" $ \_ -> do
|
||||
testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
@@ -91,13 +105,13 @@ xftpAgentTests =
|
||||
let auth = Just "abcd"
|
||||
srv = ProtoServerWithAuth testXFTPServer2
|
||||
authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH
|
||||
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right Nothing
|
||||
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
|
||||
it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr
|
||||
it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr
|
||||
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2, information = Just testServerInformation} $ \_ ->
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
@@ -326,6 +340,43 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO ()
|
||||
testNoRedundancy (ValidFileDescription FileDescription {chunks}) =
|
||||
all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True
|
||||
|
||||
testXFTPAgentEntitlement :: HasCallStack => IO ()
|
||||
testXFTPAgentEntitlement = do
|
||||
Right (issuerPk, issuerSk) <- bbsKeyGen
|
||||
now <- getCurrentTime
|
||||
let ent = Entitlement {entitlementName = "supporter", expiresAt = addUTCTime (30 * nominalDay) now, extraInfo = ""}
|
||||
keys = M.fromList [(1, issuerPk)]
|
||||
Right credential <- signEntitlement issuerSk 1 (MasterKey "0123456789abcdef0123456789abcdef") ent
|
||||
let srvCfg = testXFTPServerConfig {entitlementKeys = keys, fileStorageEntitlements = M.fromList [("supporter", EntitlementConfig (168 * 3600))]}
|
||||
withXFTPServerCfg srvCfg $ \_ -> do
|
||||
filePath <- createRandomFile_ (kb 128 :: Integer) "testfile"
|
||||
let servers = initAgentServers {AEnv.entitlements = M.fromList [(1, credential)]}
|
||||
withAgent 1 (agentCfg {AEnv.entitlementKeys = keys}) servers testDB $ \sndr -> runRight_ $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
nowSec <- liftIO $ systemSeconds <$> getSystemTime
|
||||
_ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just 100)
|
||||
gExpires <- waitSndDone sndr
|
||||
liftIO $ expiresIn gExpires nowSec (100 * 3600)
|
||||
-- the same request without the credential is capped at the default maximum
|
||||
withAgent 2 (agentCfg {AEnv.entitlementKeys = keys}) initAgentServers testDB2 $ \sndr -> runRight_ $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
nowSec <- liftIO $ systemSeconds <$> getSystemTime
|
||||
_ <- XA.xftpSendFile sndr 1 (CF.plain filePath) 1 (Just 100)
|
||||
gExpires <- waitSndDone sndr
|
||||
let ExpirationConfig {ttl} = defaultFileExpiration
|
||||
liftIO $ expiresIn gExpires nowSec ttl
|
||||
where
|
||||
expiresIn gExpires nowSec secs = case gExpires of
|
||||
Just (GSTExpires t) -> do
|
||||
t `shouldSatisfy` (>= nowSec + secs)
|
||||
t `shouldSatisfy` (< nowSec + secs + 7200)
|
||||
Nothing -> expectationFailure "expected granted storage time in SFDONE"
|
||||
waitSndDone sndr =
|
||||
sfGet sndr >>= \case
|
||||
("", _, A.SFDONE _ _ g) -> pure g
|
||||
("", _, SFPROG _ _) -> waitSndDone sndr
|
||||
r -> error $ "Expected SFDONE, got " <> show r
|
||||
|
||||
testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
|
||||
testReceive rcp rfd = testReceiveCF rcp rfd Nothing
|
||||
|
||||
@@ -619,7 +670,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te
|
||||
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO ()
|
||||
testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = Just fastExpiration}) . const $ do
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
|
||||
+12
-2
@@ -19,6 +19,10 @@ import Simplex.FileTransfer.Server (runXFTPServerBlocking)
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig (..), AFStoreType (..), defaultFileExpiration, defaultInactiveClientExpiration)
|
||||
import Simplex.FileTransfer.Server.Store (FileStoreClass, SFSType (..), STMFileStore)
|
||||
import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
|
||||
import Simplex.FileTransfer.Types (SndFileId)
|
||||
import qualified Simplex.Messaging.Agent as A
|
||||
import Simplex.Messaging.Agent.Protocol (UserId)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server
|
||||
@@ -32,6 +36,9 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
#endif
|
||||
|
||||
xftpSendFile :: A.AgentClient -> UserId -> CryptoFile -> Int -> A.AE SndFileId
|
||||
xftpSendFile c userId file n = A.xftpSendFile c userId file n Nothing
|
||||
|
||||
data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerConfig s)
|
||||
|
||||
updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig
|
||||
@@ -181,7 +188,9 @@ testXFTPServerConfig =
|
||||
newFileBasicAuth = Nothing,
|
||||
controlPortAdminAuth = Nothing,
|
||||
controlPortUserAuth = Nothing,
|
||||
fileExpiration = Just defaultFileExpiration,
|
||||
fileExpiration = defaultFileExpiration,
|
||||
fileStorageEntitlements = mempty,
|
||||
entitlementKeys = mempty,
|
||||
fileTimeout = 10000000,
|
||||
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
||||
xftpCredentials =
|
||||
@@ -192,6 +201,7 @@ testXFTPServerConfig =
|
||||
},
|
||||
httpCredentials = Nothing,
|
||||
xftpServerVRange = supportedFileServerVRange,
|
||||
information = Nothing,
|
||||
logStatsInterval = Nothing,
|
||||
logStatsStartTime = 0,
|
||||
serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log",
|
||||
@@ -215,7 +225,7 @@ testXFTPClient = testXFTPClientWith testXFTPClientConfig
|
||||
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
|
||||
testXFTPClientWith cfg client = do
|
||||
ts <- getCurrentTime
|
||||
getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure ()) >>= \case
|
||||
getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case
|
||||
Right c -> client c
|
||||
Left e -> error $ show e
|
||||
|
||||
|
||||
@@ -22,13 +22,15 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.List (find, isInfixOf)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import qualified Data.X509 as X
|
||||
import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import Network.HPACK.Token (tokenKey)
|
||||
import qualified Network.HTTP2.Client as H2
|
||||
import ServerTests (logSize)
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.FileTransfer.Client hiding (createXFTPChunk)
|
||||
import qualified Simplex.FileTransfer.Client as A
|
||||
import Simplex.FileTransfer.Description (kb)
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId, xftpBlockSize)
|
||||
import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
|
||||
@@ -37,7 +39,7 @@ import Simplex.Messaging.Client (ProtocolClientError (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), RecipientId, SenderId, pattern NoEntity)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient)
|
||||
@@ -100,6 +102,9 @@ createTestChunk fp = do
|
||||
B.writeFile fp bytes
|
||||
pure bytes
|
||||
|
||||
createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing
|
||||
|
||||
readChunk :: XFTPFileId -> IO ByteString
|
||||
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
|
||||
|
||||
@@ -240,13 +245,13 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs
|
||||
deleteXFTPChunk c spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
where
|
||||
fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
testInactiveClientExpiration :: AFStoreType -> Expectation
|
||||
testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do
|
||||
disconnected <- newEmptyTMVarIO
|
||||
ts <- liftIO getCurrentTime
|
||||
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> atomically $ putTMVar disconnected ())
|
||||
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig [] ts (\_ -> pure Nothing) (\_ -> atomically $ putTMVar disconnected ())
|
||||
pingXFTP c
|
||||
liftIO $ do
|
||||
threadDelay 100000
|
||||
@@ -538,7 +543,7 @@ testWebHandshake =
|
||||
-- Verify signedPubKey (DH key auth)
|
||||
void $ either error pure $ C.verifyX509 leafPubKey signedPubKey
|
||||
-- Send client handshake with echoed challenge
|
||||
let clientHs = XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash}
|
||||
let clientHs = XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash, entitlementProof = Nothing}
|
||||
clientHsPadded <- either (error . show) pure $ C.pad (smpEncode clientHs) xftpBlockSize
|
||||
let clientHsReq = H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded
|
||||
resp2 <- either (error . show) pure =<< HC.sendRequest h2 clientHsReq (Just 5000000)
|
||||
@@ -564,7 +569,7 @@ testWebReHandshake =
|
||||
resp1 <- either (error . show) pure =<< HC.sendRequest h2 helloReq1 (Just 5000000)
|
||||
serverHs1 <- either (error . show) pure $ C.unPad (bodyHead (HC.respBody resp1))
|
||||
XFTPServerHandshake {sessionId = sid1} <- either error pure $ smpDecode serverHs1
|
||||
clientHsPadded <- either (error . show) pure $ C.pad (smpEncode (XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash})) xftpBlockSize
|
||||
clientHsPadded <- either (error . show) pure $ C.pad (smpEncode (XFTPClientHandshake {xftpVersion = VersionXFTP 1, keyHash, entitlementProof = Nothing})) xftpBlockSize
|
||||
resp1b <- either (error . show) pure =<< HC.sendRequest h2 (H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded) (Just 5000000)
|
||||
B.length (bodyHead (HC.respBody resp1b)) `shouldBe` 0
|
||||
-- Re-handshake on same connection with xftp-web-hello header
|
||||
|
||||
@@ -46,9 +46,9 @@ import Test.Hspec hiding (fit, it)
|
||||
import Util
|
||||
import Simplex.FileTransfer.Server.Env (XFTPServerConfig)
|
||||
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
||||
import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpTestPort)
|
||||
import XFTPClient (testXFTPServerConfigEd25519SNI, testXFTPServerConfigSNI, withXFTPServerCfg, xftpSendFile, xftpTestPort)
|
||||
import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAgent)
|
||||
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..))
|
||||
import SMPAgentClient (agentCfg, initAgentServers, testDB)
|
||||
import XFTPCLI (recipientFiles, senderFiles, testBracket)
|
||||
@@ -2885,6 +2885,7 @@ webHandshakeTest cfg caFile = do
|
||||
\import sodium from 'libsodium-wrappers-sumo';\
|
||||
\import * as Addr from './dist/protocol/address.js';\
|
||||
\import * as Hs from './dist/protocol/handshake.js';\
|
||||
\import * as Tx from './dist/protocol/transmission.js';\
|
||||
\import * as Id from './dist/crypto/identity.js';\
|
||||
\await sodium.ready;\
|
||||
\const server = Addr.parseXFTPServer('"
|
||||
@@ -2905,7 +2906,7 @@ webHandshakeTest cfg caFile = do
|
||||
\ ? Id.verifyIdentityProof({certChainDer: hs.certChainDer, signedKeyDer: hs.signedKeyDer,\
|
||||
\sigBytes: hs.webIdentityProof, challenge, sessionId: hs.sessionId, keyHash: server.keyHash})\
|
||||
\ : false;\
|
||||
\const ver = hs.xftpVersionRange.maxVersion;\
|
||||
\const ver = Math.min(hs.xftpVersionRange.maxVersion, Tx.currentXFTPVersion);\
|
||||
\const s2 = client.request({':method': 'POST', ':path': '/', 'xftp-handshake': '1'});\
|
||||
\s2.end(Buffer.from(Hs.encodeClientHandshake({xftpVersion: ver, keyHash: server.keyHash})));\
|
||||
\const ack = await readBody(s2);\
|
||||
@@ -3197,7 +3198,7 @@ haskellUploadTsDownloadTest cfg = do
|
||||
runRight_ $ xftpStartWorkers sndr (Just senderFiles)
|
||||
_ <- runRight $ xftpSendFile sndr 1 (CF.plain filePath) 1
|
||||
sfProgress sndr 50000
|
||||
(_, _, SFDONE _ [rfd]) <- sfGet sndr
|
||||
(_, _, SFDONE _ [rfd] _) <- sfGet sndr
|
||||
pure rfd
|
||||
let yamlDesc = strEncode vfd
|
||||
tmpYaml = "tests/tmp/hs-to-ts-desc.yaml"
|
||||
|
||||
Reference in New Issue
Block a user