Compare commits

...
Author SHA1 Message Date
Evgeny Poberezkin b11bb9f52e Merge branch 'master' into short-links 2024-09-09 16:01:23 +01:00
Evgeny Poberezkin e362e816c9 rfc: queue storage 2024-09-05 19:59:38 +01:00
Evgeny Poberezkin 36b49b66f8 Merge branch 'master' into short-links 2024-09-05 15:10:25 +01:00
Evgeny Poberezkin 4599dafa16 smp client: api to send/receive data blobs directly and via proxy, tests (#1246)
* smp client: api to send/receive data blobs directly and via proxy, tests

* fix test
2024-07-27 07:50:25 +01:00
Evgeny Poberezkin fd009fe0d9 smp server: persistence for data blobs (#1245) 2024-07-25 21:46:47 +01:00
Evgeny Poberezkin eee8c0ba78 Merge branch 'master' into short-links 2024-07-25 16:07:02 +01:00
Evgeny Poberezkin a10d128cdc Merge branch 'master' into short-links 2024-07-25 13:15:34 +01:00
Evgeny Poberezkin f334843e01 smp server: key-value storage (for short invitation links) (#1206)
* rfc: short invitation links

* shorter

* types

* server implementation, client functions

* test

* update rfc

* test name
2024-07-25 13:15:03 +01:00
15 changed files with 734 additions and 53 deletions
+124
View File
@@ -0,0 +1,124 @@
# Short invitation links
## Problem
Long links look scary and unsafe for many users. While this is a perceived problem, rather than a real one, it hurts adoption.
What is worse, long links do not fit in profile descriptions of other social networks where people might want to advertize their contact addresses.
The current link size limitation is also the reason for not including PQ KEM keys into invitation links and addresses, postponing the moment when PQ-resistant encryption kicks in - if we include PQ KEM key into the link, the QR code will not be scannable.
Additionally, if we store short links, they can also include chat preferences and public profile data.
## Solution
MITM-resistant link shortening.
Instead of generating the random address that would resolve into the link - doing so would create the possibility of MITM by the server hosting this link - we can use private key as the link ID that will be passed to the accepting party, and the hash of the public key as ID for the server - the accepting party would present this key itself as ID and it will also be used for server to client encryption (see Protocol below). HKDF will be used to derive symmetric key from private key and used in secret_box together with random nonce (to allow replacing data with the same key but with a different nonce - nonce will be sent to the server too). secret_box construction is authenticated encryption, so it would protect from MITM.
The proposed syntax:
```abnf
shortConnectionRequest = connectionScheme "/" connReqType "#/" smpServer "/" linkHash
connReqType = %s"invitation" / %s"contact"
connectionScheme = (%s"https://" clientAppServer) / %s"simplex:"
clientAppServer = hostname [ ":" port ]
; client app server, e.g. simplex.chat
smpServer = serverIdentity "@" srvHosts [":" port] ; no smp:// prefix, no escaping
srvHosts = <hostname> ["," srvHosts] ; RFC1123, RFC5891
linkHash = <base64url encoded SHA256 or SHA512 hash of the original link>
```
If SMP server supports pages, its name can be used as clientAppServer, without repeating it after #, for a shorter link.
Example link:
```
https://simplex.chat/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU=@smp8.simplex.im/abcdefghij0123456789abcdefghij0123456789abc=
```
This link has the length of ~136 characters (256 bits), which is shorter than the full contact address (~310 characters) and much shorter than invitation links (~528 characters) even without post-quantum keys added to them.
This size can be further reduced by
- use server domain in the link.
- do not include onion address, as the connection happens via proxy anyway, if it's untrusted server.
- not pinning server TLS certificate - the downside here is that while the attack that compromises TLS will not be able to substitute the link (because it's hash will not match), it will be able to intercept and to block it.
- using shorter hash, e.g. SHA128 - reducing the collision resistance.
If the server is known, the client could use it's hash and onion address, otherwise it could trust the proxy to use any existing session with the same hostname or to accept the risk of interception - given that there is no risk of substitution.
With the first two of these "improvements" the link could be ~122 characters:
```
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@/abcdefghij0123456789abcdefghij0123456789abc
```
If onion address is preserved the link will be ~184 characters (won't fit in Twitter 160 characters bio):
```
https://smp8.simplex.im/contact/#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
```
If we implement it, the request to resolve the link would be made via proxied SMP command (to avoid the direct connection between the client and the recipient's server).
Pros:
- a bit shorter link.
- possibility to include post-quantum keys into the full link keeping the same shortened link size.
- possibility to include chat profile of contact or group, and preferences, for a much better connection experience, and to show this information when the link sent in the conversation (clients can resolve them automatically, without connecting - it can be resolved by the sending clients).
- server will not have access to the link.
Cons:
- protocol complexity.
- observers can access the link content, so for 1-time invitation we should only include permissions and not profile.
Pros are a huge improvement of UX of connecting both within and from outside of the app (e.g., link can be resolved even before creating chat profile, as part of the onboarding).
## Protocol
To support short links, the SMP servers would provide a simple key-value store enabled by three additional commands: `WRT`, `CLR` and `READ`
`WRT` command is used to store and to update values in the store. The size of the value is limited by the same size as sent messages (or, possibly, smaller - as connection information size used in confirmation messages) - the clients would use this fixed size irrespective of the content. `WRT` command will be sent with the data blob ID in the transaction entityId field, public authorization key used to authorize `WRT` and `CLR` commands (subsequent WRT commands to the existing key must use the same key), and the data blob.
`CLR` command must use with the same entity ID and must be authorized by the same key.
`READ` command must use the ID which hash would be equal of the ID used to create the data blob, and this ID would also be used as public authorization
## Algorithm to store and to retrieve data blob.
**Store data blob**
- the data blob owner generates X25519 key pair: `(k, pk)`.
- private key `pk` will be included in the short link shared with the other party (only base64url encoded key bytes, not X509 encoding).
- `HKDF(pk)` will be used to encrypt the link data with secret_box before storing it on the server.
- the hash of public key `sha256(k)` will be used as ID by the owner to store and to remove the data blob (`WRT` and `CLR` commands).
**Retrieve data blob**
- the sender uses the public key `k` derived from the private key `pk` included in the link as entity ID to retrieve data blob (the server will compute the ID used by the owner as `sha256(k)` and will be able to look it up). This provides the quality that the traffic of the parties has no shared IDs inside TLS. It also means that unlike message queue creation, the ID to retrieve the blob was never sent to the blob creator, and also is not known to the server in advance (the second part is only an observation, in itself it does not increase security, as server has access to an encrypted blob anyway).
- note that the sender does not authorize the request to retrieve the blob, as it would not increase security unless a different key is used to authorize, and adding a key would increase link size.
- server session keys with the sender will be `(sk, spk)`, where `sk` is public key shared with the sender during session handshake, and `spk` is the private key known only to the server.
- this public key `k` will also be combined with server session key `spk` using `dh(k, spk)` to encrypt the response, so that there is no ciphertext in common in sent and received traffic for these blobs. Correlation ID will be used as a nonce for this encryption.
- having received the blob, the client can now decrypt it using secret_box with `HKDF(pk)`.
Using the same key as ID for the request, and also to additionally encrypt the response allows to use a single key in the link, without increasing the link size.
## Threat model
**Compromised SMP server**
can:
- delete link data.
- hide link selectively from some requests.
cannot:
- undetectably replace link data.
- access unencrypted link data, whether it was or was not accessed by the accepting party.
- observe IP addresses of the users accessing link data.
**Passive observer who observed short link**:
can:
- access original unencrypted link data
cannot:
- replace or delete the link data
+81
View File
@@ -0,0 +1,81 @@
# Storage considerations for SMP queues
See [Short invitation links](./2024-06-21-short-links.md).
## Problem
1) queue records are created permanently, until the clients delete them.
2) clients only delete queue records based on some user action, pending connections do not expire.
While part 2 should be improved in the client, indefinite storage of queue records becomes a much bigger issue if each of them would result in a permanent storage of 4-16kb blob in server memory, without server-side expiration for short invitation links.
## Possible solutions
1) Add some queue timestamp, e.g. queue creation date, to expire unsecured queues after say 3 weeks.
The problem with this approach is that contact addresses are also unsecured queues, and they should not be expired.
We could set really large expiration time, and require that clients "update" the unsecured queues they need at least every 1-2 years, but it would not solve the problem of storing a large number of blobs in the server memory for unused/abandoned 1-time invitations.
2) Do not store blobs in memory / append-only log, and instead use something like RocksDB. While it may be a correct long term solution, it may be not expedient enough at the current POC stage for this feature. Also, the lack of expiration is wrong in any case and would indefinitely grow server storage.
3) Add flag allowing the server to differentiate permanent queues used as contact addresses, also using different blob sizes for them. In this case, messaging queues will be expired if not secured after 3 weeks, and contact address queues would be expired if not "updated" by the owner within 2 years.
Probably all three solutions need to be used, to avoid creating a non-expiring blob storage in memory, as in case too many of such blobs are created it would not be possible to differentiate between real users and resource exhaustion attacks, and unlike with messages, they won't be expiring too.
Servers already can differentiate messaging queues and contact address queues, if they want to:
- with the old 4-message handshake, the confirmation message on a normal queue was different, and also KEY command was eventually used.
- with the fast 2-message handshake, while the confirmation message has the same syntax, and the differences are inside encrypted envelope, the client still uses SKEY command.
- in both cases, the usual messaging queues are secured, and contact addresses are not, so this difference is visible in the storage as well (although it is not easy to differentiate between abandoned 1-time invitations and contact addresses).
Differentiating these queues can also allow different message retention times - e.g., the queues for contact addresses could have bigger size, but have lower message retention time.
## Proposed solution
1. Add queue updated_at date into queue records. While it adds some metadata, it seems necessary to manage retention and quality of service. It will not include exact time, only date, and the time of creation will be replaced by the time of any update - queue secured, a message is sent, or queue owner subscribes to the queue. To avoid the need to update store log on every message this information can be appended to store log on server termination. Or given that only one update per day is needed it may be ok to make these updates as they happen (temporarily making the sequence and time of these events available in storage).
2. Add flag to indicate the queue usage - messaging queue or queue for contact address connection requests. This would result in different queue size and different retention policy for queue and its messages. We already have "sender can secure flag" which is, effectively, this flag - contact address queues are never secured. So this does not increase stored metadata in any way.
## Possible changes to short links
This is a design considerations and a concept, not a design yet.
Instead of implementing a generic blob storage that can be used as an attack vector, and adds additional failure point (another server storing blob that is necessary to connect to the queue on the current server), but instead adds an extended queue information blobs, most of which could be dropped without the loss of connectivity, so that the attack can be mitigated by deleting these blobs without users losing the ability to connect, as long as the queue and minimal extended information is retained.
So, to make the connection there need to be these elements:
- queue server and queue ID - mandatory part, that can be included in short link
- SMP key - mandatory part for all queues. We are considering initializing ratchets earlier for contact addresses, and include ratchet keys and pre-keys into queue data as well, but it is out of scope here.
- Ratchet keys - mandatory part for 1-time invitation that won't fit in short link.
- PQ key - optional part that can be stored with addresses if ratchet keys are added and with 1-time invitations.
- App blobs - chat preferences for 1-time invitation links and profile information for contact addresses.
So rather that storing one blob with a large address inside it, not associated with the queue, increasing probability of failure and reducing our ability to mitigate resource exhaustion, we could store extended blobs associated with the queues.
Also, we need the address shared with the sender (party accepting the connection) to be short. We could use a similar approach that was proposed for data blobs, using a single random seed per queues to derive multiple keys and IDs from it. For example:
1. The queue owner:
- generates Ed25529 key pair `(sk, spk)` and X25519 key pair `(dhk, dhpk)` to use with the server, same as now sent in NEW command.
- generates queue recipient ID (this ID can still be server-generated).
- generates X25519 key pair `(k, pk)` to use with the accepting party.
- derives from `k`:
- sender ID.
- symmetric key for authenticated encryption of blobs.
- `k` will be used as short link.
2. All other data from the invitation can be included in queue creation request and be associated with the queue as 1-3 blobs with different priority:
- ratchet keys - it will have a small size, so only this blob cannot be removed, while other blobs can be removed in case of resource exhaustion.
- PQ keys - optional blob.
- conversation preferences and profile - can be removed depending on creation time, e.g. all new blobs can be removed.
The algorithm used to derive key and ID from `k` needs to be cryptographically secure, e.g. it could be some KDF or ChaCha DRG initialized with `k` as seed, TBC.
So, coupling blob storage with messaging queues has these pros/cons:
Cons:
- no additional layer of privacy - the server used for connection is visible in the link, even after the blobs are removed from the server.
Pros:
- no additional point of failure in the connection process - the same server will be used to retrieve necessary blobs as for connection.
- queue blobs of messaging blobs will be automatically removed once the queue is secured or expired, without additional request from the recipient - reducing the storage and the time these blobs are available.
- queue blobs for contact addresses will be structured and some of the large blobs can be removed in case of resource exhaustion attack (and recreated by the client if needed), with the only downside that PQ handshake will be postponed (which is the case now) and profile will not be available at a point of connection.
+2
View File
@@ -167,6 +167,8 @@ library
Simplex.Messaging.Server
Simplex.Messaging.Server.CLI
Simplex.Messaging.Server.Control
Simplex.Messaging.Server.DataLog
Simplex.Messaging.Server.DataStore
Simplex.Messaging.Server.Env.STM
Simplex.Messaging.Server.Expiration
Simplex.Messaging.Server.Information
+66 -10
View File
@@ -58,6 +58,10 @@ module Simplex.Messaging.Client
suspendSMPQueue,
deleteSMPQueue,
deleteSMPQueues,
createSMPDataBlob,
deleteSMPDataBlob,
getSMPDataBlob,
proxyGetSMPDataBlob,
connectSMPProxiedRelay,
proxySMPMessage,
forwardSMPTransmission,
@@ -114,6 +118,8 @@ import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bitraversable (bimapM)
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
@@ -749,9 +755,14 @@ secureSndSMPQueue c spKey sId senderKey = okSMPCommand (SKEY senderKey) c spKey
{-# INLINE secureSndSMPQueue #-}
proxySecureSndSMPQueue :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> SenderId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
proxySecureSndSMPQueue c proxiedRelay spKey sId senderKey = proxySMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey) okResult
{-# INLINE proxySecureSndSMPQueue #-}
okResult :: BrokerMsg -> Maybe ()
okResult = \case
OK -> Just ()
_ -> Nothing
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
@@ -793,7 +804,7 @@ sendSMPMessage c spKey sId flags msg =
r -> throwE $ unexpectedResponse r
proxySMPMessage :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg)
proxySMPMessage c proxiedRelay spKey sId flags msg = proxySMPCommand c proxiedRelay spKey sId (SEND flags msg) okResult
-- | Acknowledge message delivery (server deletes the message).
--
@@ -825,6 +836,43 @@ deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO
deleteSMPQueues = okSMPCommands DEL
{-# INLINE deleteSMPQueues #-}
createSMPDataBlob :: SMPClient -> C.AAuthKeyPair -> BlobId -> DataBlob -> ExceptT SMPClientError IO ()
createSMPDataBlob c (dKey, dpKey) dId blob = okSMPCommand (WRT dKey blob) c dpKey dId
{-# INLINE createSMPDataBlob #-}
deleteSMPDataBlob :: SMPClient -> DataPrivateAuthKey -> BlobId -> ExceptT SMPClientError IO ()
deleteSMPDataBlob = okSMPCommand CLR
{-# INLINE deleteSMPDataBlob #-}
-- pk is the private key passed to the client out of band.
-- Associated public key is used as ID to retrieve data blob
getSMPDataBlob :: SMPClient -> C.PrivateKeyX25519 -> ExceptT SMPClientError IO DataBlob
getSMPDataBlob c@ProtocolClient {thParams, client_ = PClient {clientCorrId = g}} pk = do
serverKey <- case thAuth thParams of
Nothing -> throwE $ PCETransportError TENoServerAuth
Just THAuthClient {serverPeerPubKey = k} -> pure k
nonce <- liftIO . atomically $ C.randomCbNonce g
let dId = EntityId $ BA.convert $ C.pubKeyBytes $ C.publicKey pk
sendProtocolCommand_ c (Just nonce) Nothing Nothing dId (Cmd SSender READ) >>= \case
DATA encBlob -> decryptDataBlob serverKey pk nonce encBlob
r -> throwE $ unexpectedResponse r
proxyGetSMPDataBlob :: SMPClient -> ProxiedRelay -> C.PrivateKeyX25519 -> ExceptT SMPClientError IO (Either ProxyClientError DataBlob)
proxyGetSMPDataBlob c@ProtocolClient {client_ = PClient {clientCorrId = g}} proxiedRelay@ProxiedRelay {prServerKey} pk = do
nonce <- liftIO . atomically $ C.randomCbNonce g
let dId = EntityId $ BA.convert $ C.pubKeyBytes $ C.publicKey pk
encBlob_ <-
proxySMPCommand_ c (Just nonce) proxiedRelay Nothing dId READ $ \case
DATA encBlob -> Just encBlob
_ -> Nothing
bimapM pure (decryptDataBlob prServerKey pk nonce) encBlob_
decryptDataBlob :: C.PublicKeyX25519 -> C.PrivateKeyX25519 -> C.CbNonce -> ByteString -> ExceptT (ProtocolClientError ErrorType) IO DataBlob
decryptDataBlob serverKey pk nonce encBlob = do
let ss = C.dh' serverKey pk
blobStr <- liftEitherWith PCECryptoError $ C.cbDecrypt ss nonce encBlob
liftEitherWith (const $ PCEResponseError BLOCK) $ smpDecode blobStr
-- send PRXY :: SMPServer -> Maybe BasicAuth -> Command Sender
-- receives PKEY :: SessionId -> X.CertificateChain -> X.SignedExact X.PubKey -> BrokerMsg
connectSMPProxiedRelay :: SMPClient -> SMPServer -> Maybe BasicAuth -> ExceptT SMPClientError IO ProxiedRelay
@@ -878,6 +926,9 @@ instance StrEncoding ProxyClientError where
"SYNTAX" -> ProxyResponseError <$> _strP
_ -> fail "bad ProxyClientError"
proxySMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> (BrokerMsg -> Maybe r) -> ExceptT SMPClientError IO (Either ProxyClientError r)
proxySMPCommand c = proxySMPCommand_ c Nothing
-- consider how to process slow responses - is it handled somehow locally or delegated to the caller
-- this method is used in the client
-- sends PFWD :: C.PublicKeyX25519 -> EncTransmission -> Command Sender
@@ -905,22 +956,25 @@ instance StrEncoding ProxyClientError where
-- - other errors from the client running on proxy and connected to relay in PREProxiedRelayError
-- This function proxies Sender commands that return OK or ERR
proxySMPCommand ::
proxySMPCommand_ ::
SMPClient ->
-- optional correlation ID/nonce for the sending client
Maybe C.CbNonce ->
-- proxy session from PKEY
ProxiedRelay ->
-- message to deliver
-- command to deliver
Maybe SndPrivateAuthKey ->
SenderId ->
Command 'Sender ->
ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
(BrokerMsg -> Maybe r) ->
ExceptT SMPClientError IO (Either ProxyClientError r)
proxySMPCommand_ c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} nonce_ (ProxiedRelay sessionId v _ serverKey) spKey sId command toResult = do
-- prepare params
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
serverThParams = smpTHParamsSetVersion v proxyThParams {sessionId, thAuth = serverThAuth}
(cmdPubKey, cmdPrivKey) <- liftIO . atomically $ C.generateKeyPair @'C.X25519 g
let cmdSecret = C.dh' serverKey cmdPrivKey
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
nonce@(C.CbNonce corrId) <- liftIO $ maybe (atomically $ C.randomCbNonce g) pure nonce_
-- encode
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
@@ -940,9 +994,11 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
case tParse serverThParams t' of
t'' :| [] -> case tDecodeParseValidate serverThParams t'' of
(_auth, _signed, (_c, _e, cmd)) -> case cmd of
Right OK -> pure $ Right ()
Right (ERR e) -> throwE $ PCEProtocolError e -- this is the error from the destination relay
Right r' -> throwE $ unexpectedResponse r'
Right r' -> case toResult r' of
Just r'' -> pure $ Right r''
Nothing -> case r' of
ERR e -> throwE $ PCEProtocolError e -- this is the error from the destination relay
_ -> throwE $ unexpectedResponse r'
Left e -> throwE $ PCEResponseError e
_ -> throwE $ PCETransportError TEBadBlock
ERR e -> pure . Left $ ProxyProtocolError e -- this will not happen, this error is returned via Left
+67 -5
View File
@@ -104,6 +104,7 @@ module Simplex.Messaging.Protocol
EntityId (..),
pattern NoEntity,
QueueId,
BlobId,
RecipientId,
SenderId,
NotifierId,
@@ -117,6 +118,8 @@ module Simplex.Messaging.Protocol
NtfPublicAuthKey,
RcvNtfPublicDhKey,
RcvNtfDhSecret,
DataPrivateAuthKey,
DataPublicAuthKey,
Message (..),
RcvMessage (..),
MsgId,
@@ -136,6 +139,8 @@ module Simplex.Messaging.Protocol
FwdResponse (..),
FwdTransmission (..),
MsgFlags (..),
DataBlob (..),
EncDataBlob,
initialSMPClientVersion,
currentSMPClientVersion,
userProtocol,
@@ -377,6 +382,8 @@ type NotifierId = QueueId
-- | SMP queue ID on the server.
type QueueId = EntityId
type BlobId = EntityId
-- this type is used for server entities only
newtype EntityId = EntityId {unEntityId :: ByteString}
deriving (Eq, Ord, Show)
@@ -404,6 +411,10 @@ data Command (p :: Party) where
OFF :: Command Recipient
DEL :: Command Recipient
QUE :: Command Recipient
-- Data storage commands
WRT :: DataPublicAuthKey -> DataBlob -> Command Recipient
CLR :: Command Recipient
READ :: Command Sender
-- SMP sender commands
SKEY :: SndPublicAuthKey -> Command Sender
-- SEND v1 has to be supported for encoding/decoding
@@ -412,6 +423,7 @@ data Command (p :: Party) where
PING :: Command Sender
-- SMP notification subscriber commands
NSUB :: Command Notifier
-- Proxy commands
PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
-- Transmission to proxy:
-- - entity ID: ID of the session with relay returned in PKEY (response to PRXY)
@@ -485,6 +497,7 @@ data BrokerMsg where
PRES :: EncResponse -> BrokerMsg -- proxy to client
END :: BrokerMsg
INFO :: QueueInfo -> BrokerMsg
DATA :: EncDataBlob -> BrokerMsg
OK :: BrokerMsg
ERR :: ErrorType -> BrokerMsg
PONG :: BrokerMsg
@@ -682,6 +695,9 @@ data CommandTag (p :: Party) where
OFF_ :: CommandTag Recipient
DEL_ :: CommandTag Recipient
QUE_ :: CommandTag Recipient
WRT_ :: CommandTag Recipient
CLR_ :: CommandTag Recipient
READ_ :: CommandTag Sender
SKEY_ :: CommandTag Sender
SEND_ :: CommandTag Sender
PING_ :: CommandTag Sender
@@ -706,6 +722,7 @@ data BrokerMsgTag
| PRES_
| END_
| INFO_
| DATA_
| OK_
| ERR_
| PONG_
@@ -731,6 +748,9 @@ instance PartyI p => Encoding (CommandTag p) where
OFF_ -> "OFF"
DEL_ -> "DEL"
QUE_ -> "QUE"
WRT_ -> "WRT"
CLR_ -> "CLR"
READ_ -> "READ"
SKEY_ -> "SKEY"
SEND_ -> "SEND"
PING_ -> "PING"
@@ -752,6 +772,9 @@ instance ProtocolMsgTag CmdTag where
"OFF" -> Just $ CT SRecipient OFF_
"DEL" -> Just $ CT SRecipient DEL_
"QUE" -> Just $ CT SRecipient QUE_
"WRT" -> Just $ CT SRecipient WRT_
"CLR" -> Just $ CT SRecipient CLR_
"READ" -> Just $ CT SSender READ_
"SKEY" -> Just $ CT SSender SKEY_
"SEND" -> Just $ CT SSender SEND_
"PING" -> Just $ CT SSender PING_
@@ -779,6 +802,7 @@ instance Encoding BrokerMsgTag where
PRES_ -> "PRES"
END_ -> "END"
INFO_ -> "INFO"
DATA_ -> "DATA"
OK_ -> "OK"
ERR_ -> "ERR"
PONG_ -> "PONG"
@@ -795,6 +819,7 @@ instance ProtocolMsgTag BrokerMsgTag where
"PRES" -> Just PRES_
"END" -> Just END_
"INFO" -> Just INFO_
"DATA" -> Just DATA_
"OK" -> Just OK_
"ERR" -> Just ERR_
"PONG" -> Just PONG_
@@ -1169,12 +1194,38 @@ type RcvNtfPublicDhKey = C.PublicKeyX25519
-- | DH Secret used to encrypt notification metadata from server to recipient
type RcvNtfDhSecret = C.DhSecretX25519
-- | private key to authorize owner access to data blobs
type DataPrivateAuthKey = C.APrivateAuthKey
-- | public key to authorize owner access to data blobs
type DataPublicAuthKey = C.APublicAuthKey
-- | SMP message server ID.
type MsgId = ByteString
-- | SMP message body.
type MsgBody = ByteString
data DataBlob = DataBlob
{ dataNonce :: C.CbNonce,
dataBody :: ByteString
}
deriving (Eq, Show)
instance Encoding DataBlob where
smpEncode DataBlob {dataNonce, dataBody} = smpEncode (dataNonce, Tail dataBody)
smpP = do
(dataNonce, Tail dataBody) <- smpP
pure DataBlob {dataNonce, dataBody}
instance StrEncoding DataBlob where
strEncode DataBlob {dataNonce, dataBody} = strEncode (dataNonce, dataBody)
strP = do
(dataNonce, dataBody) <- strP
pure DataBlob {dataNonce, dataBody}
type EncDataBlob = ByteString
data ProtocolErrorType = PECmdSyntax | PECmdUnknown | PESession | PEBlock
-- | Type for protocol errors.
@@ -1319,6 +1370,9 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
OFF -> e OFF_
DEL -> e DEL_
QUE -> e QUE_
WRT k blob -> e (WRT_, ' ', k, blob)
CLR -> e CLR_
READ -> e READ_
SKEY k -> e (SKEY_, ' ', k)
SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
PING -> e PING_
@@ -1348,14 +1402,12 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
SKEY _
| isNothing auth || B.null entId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
READ -> entityNoAuthCmd
PING -> noAuthCmd
PRXY {} -> noAuthCmd
PFWD {}
| B.null entId -> Left $ CMD NO_ENTITY
| isNothing auth -> Right cmd
| otherwise -> Left $ CMD HAS_AUTH
PFWD {} -> entityNoAuthCmd
RFWD _ -> noAuthCmd
-- other client commands must have both signature and queue ID
-- other client commands must have both signature and entity ID
_
| isNothing auth || B.null entId -> Left $ CMD NO_AUTH
| otherwise -> Right cmd
@@ -1365,6 +1417,11 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
noAuthCmd
| isNothing auth && B.null entId = Right cmd
| otherwise = Left $ CMD HAS_AUTH
entityNoAuthCmd :: Either ErrorType (Command p)
entityNoAuthCmd
| B.null entId = Left $ CMD NO_ENTITY
| isJust auth = Left $ CMD HAS_AUTH
| otherwise = Right cmd
instance ProtocolEncoding SMPVersion ErrorType Cmd where
type Tag Cmd = CmdTag
@@ -1390,10 +1447,13 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
OFF_ -> pure OFF
DEL_ -> pure DEL
QUE_ -> pure QUE
WRT_ -> WRT <$> _smpP <*> smpP
CLR_ -> pure CLR
CT SSender tag ->
Cmd SSender <$> case tag of
SKEY_ -> SKEY <$> _smpP
SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
READ_ -> pure READ
PING_ -> pure PING
RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
CT SProxiedClient tag ->
@@ -1424,6 +1484,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
END -> e END_
INFO info -> e (INFO_, ' ', info)
DATA body -> e (DATA_, ' ', Tail body)
OK -> e OK_
ERR err -> e (ERR_, ' ', err)
PONG -> e PONG_
@@ -1449,6 +1510,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
END_ -> pure END
INFO_ -> INFO <$> _smpP
DATA_ -> DATA . unTail <$> _smpP
OK_ -> pure OK
ERR_ -> ERR <$> _smpP
PONG_ -> pure PONG
+78 -29
View File
@@ -44,6 +44,8 @@ import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.Trans.Except
import qualified Crypto.PubKey.Curve25519 as X25519
import qualified Crypto.Error as CE
import Control.Monad.STM (retry)
import Data.Bifunctor (first)
import Data.ByteString.Base64 (encode)
@@ -81,6 +83,8 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.Control
import Simplex.Messaging.Server.DataLog
import Simplex.Messaging.Server.DataStore
import Simplex.Messaging.Server.Env.STM as Env
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
@@ -154,7 +158,11 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
saveServer :: Bool -> M ()
saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats
saveServer keepMsgs = do
withLog closeStoreLog
withLog' dataLog closeStoreLog
saveServerMessages keepMsgs
saveServerStats
closeServer :: M ()
closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
@@ -727,7 +735,7 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
write sndQ errs
write rcvQ cmds
where
updateBatchStats :: ServerStats -> [(Maybe QueueRec, Transmission Cmd)] -> M ()
updateBatchStats :: ServerStats -> [(VerificationResult, Transmission Cmd)] -> M ()
updateBatchStats stats = \case
(_, (_, _, (Cmd _ cmd))) : _ -> do
let sel_ = case cmd of
@@ -738,14 +746,13 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
_ -> Nothing
mapM_ (\sel -> incStat $ sel stats) sel_
[] -> pure ()
cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
cmdAction :: ServerStats -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (VerificationResult, Transmission Cmd))
cmdAction stats (tAuth, authorized, (corrId, entId, cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId, entId, ERR e)
Right cmd -> verified =<< verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized entId cmd
where
verified = \case
VRVerified qr -> pure $ Right (qr, (corrId, entId, cmd))
VRFailed -> do
case cmd of
Cmd _ SEND {} -> incStat $ msgSentAuth stats
@@ -754,6 +761,7 @@ receive h@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiv
Cmd _ GET -> incStat $ msgGetAuth stats
_ -> pure ()
pure $ Left (corrId, entId, ERR AUTH)
vRes -> pure $ Right (vRes, (corrId, entId, cmd))
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => MVar (THandleSMP c 'TServer) -> Client -> IO ()
@@ -805,8 +813,6 @@ disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcv
ts <- max <$> readTVarIO rcvActiveAt <*> readTVarIO sndActiveAt
if systemSeconds ts < old then closeConnection connection else loop
data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios:
-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key.
-- - the queue and party key exist, but the provided authorization has incorrect type.
@@ -814,13 +820,16 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
-- In all cases, the time of the verification should depend only on the provided authorization type,
-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
verifyTransmission auth_ tAuth authorized queueId cmd =
verifyTransmission auth_ tAuth authorized entId cmd =
case cmd of
Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
Cmd SRecipient (WRT k _) -> (\d -> d `verifiedData` (verify k && maybe True ((k ==) . dataKey) d)) <$> getData entId
Cmd SRecipient CLR -> maybe dummyVerify (\d -> Just d `verifiedData` verify (dataKey d)) <$> getData entId
Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient
-- SEND will be accepted without authorization before the queue is secured with KEY or SKEY command
Cmd SSender (SKEY k) -> verifyQueue (\q -> Just q `verifiedWith` k) <$> get SSender
Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender
Cmd SSender READ -> maybe VRFailed (VRVerifiedData . Just) <$> getData (EntityId $ C.sha256Hash $ unEntityId entId)
Cmd SSender PING -> pure $ VRVerified Nothing
Cmd SSender RFWD {} -> pure $ VRVerified Nothing
-- NSUB will not be accepted without authorization
@@ -833,10 +842,13 @@ verifyTransmission auth_ tAuth authorized queueId cmd =
verifyQueue = either (const dummyVerify)
verified q cond = if cond then VRVerified q else VRFailed
verifiedWith q k = q `verified` verify k
verifiedData d cond = if cond then VRVerifiedData d else VRFailed
get :: DirectParty p => SParty p -> M (Either ErrorType QueueRec)
get party = do
st <- asks queueStore
liftIO $ getQueue st party queueId
liftIO $ getQueue st party entId
getData :: BlobId -> M (Maybe DataRec)
getData blobId = atomically . TM.lookup blobId =<< asks dataStore
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
@@ -981,16 +993,15 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
mkIncProxyStats ps psOwn own sel = do
incStat $ sel ps
when own $ incStat $ sel psOwn
processCommand :: (Maybe QueueRec, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg))
processCommand (qr_, (corrId, entId, cmd)) = case cmd of
processCommand :: (VerificationResult, Transmission Cmd) -> M (Maybe (Transmission BrokerMsg))
processCommand (vRes, (corrId, entId, cmd)) = case cmd of
Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
Cmd SSender command -> Just <$> case command of
SKEY sKey -> (corrId,entId,) <$> case qr_ of
Just qr@QueueRec {sndSecure}
| sndSecure -> secureQueue_ "SKEY" qr sKey
| otherwise -> pure $ ERR AUTH
Nothing -> pure $ ERR INTERNAL
SKEY sKey ->
withQueue $ \QueueRec {sndSecure, recipientId} ->
(corrId,entId,) <$> if sndSecure then secureQueue_ "SKEY" recipientId sKey else pure $ ERR AUTH
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
READ -> getDataBlob
PING -> pure (corrId, NoEntity, PONG)
RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
Cmd SNotifier NSUB -> Just <$> subscribeNotifications
@@ -1009,14 +1020,16 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
SUB -> withQueue (`subscribeQueue` entId)
GET -> withQueue getMessage
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
KEY sKey -> (corrId,entId,) <$> case qr_ of
Just qr -> secureQueue_ "KEY" qr sKey
Nothing -> pure $ ERR INTERNAL
KEY sKey ->
withQueue $ \QueueRec {recipientId} ->
(corrId,entId,) <$> secureQueue_ "KEY" recipientId sKey
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
NDEL -> deleteQueueNotifier_ st
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
QUE -> withQueue getQueueInfo
WRT key blob -> storeDataBlob key blob
CLR -> deleteDataBlob
where
createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg)
createQueue st recipientKey dhKey subMode sndSecure = time "NEW" $ do
@@ -1063,10 +1076,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
n <- asks $ queueIdBytes . config
liftM2 (,) (randomId n) (randomId n)
secureQueue_ :: T.Text -> QueueRec -> SndPublicAuthKey -> M BrokerMsg
secureQueue_ name qr@QueueRec {recipientId = rId} sKey = time name $ do
secureQueue_ :: T.Text -> RecipientId -> SndPublicAuthKey -> M BrokerMsg
secureQueue_ name rId sKey = time name $ do
withLog $ \s -> logSecureQueue s rId sKey
updateQueueDate qr
st <- asks queueStore
stats <- asks serverStats
incStat $ qSecured stats
@@ -1175,9 +1187,9 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
pure r
withQueue :: (QueueRec -> M (Transmission BrokerMsg)) -> M (Transmission BrokerMsg)
withQueue action = case qr_ of
Just qr -> updateQueueDate qr >> action qr
Nothing -> pure $ err INTERNAL
withQueue action = case vRes of
VRVerified (Just qr) -> updateQueueDate qr >> action qr
_ -> pure $ err INTERNAL
updateQueueDate :: QueueRec -> M ()
updateQueueDate QueueRec {updatedAt, recipientId = rId} = do
@@ -1424,7 +1436,7 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
incStat $ pMsgFwdsRecv stats
pure $ RRES r3
where
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (VerificationResult, Transmission Cmd))
rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) =
case cmdOrError of
Left e -> pure $ Left (corrId', entId', ERR e)
@@ -1435,10 +1447,12 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
allowed = case cmd' of
Cmd SSender SEND {} -> True
Cmd SSender (SKEY _) -> True
Cmd SSender READ -> True
_ -> False
verified = \case
VRVerified qr -> Right (qr, (corrId', entId', cmd'))
VRFailed -> Left (corrId', entId', ERR AUTH)
vRes' -> Right (vRes', (corrId', entId', cmd'))
deliverMessage :: T.Text -> QueueRec -> RecipientId -> Sub -> Maybe Message -> M (Transmission BrokerMsg)
deliverMessage name qr rId s@Sub {subThread} msg_ = time (name <> " deliver") . atomically $
case subThread of
@@ -1508,6 +1522,39 @@ client thParams' clnt@Client {clientId, subscriptions, ntfSubscriptions, rcvQ, s
qDelivered <- atomically $ decodeLatin1 . encode <$$> tryReadTMVar delivered
pure QSub {qSubThread, qDelivered}
storeDataBlob :: DataPublicAuthKey -> DataBlob -> M (Transmission BrokerMsg)
storeDataBlob dataKey dataBlob
| B.length (dataBody dataBlob) > e2eEncMessageLength = pure $ err LARGE_MSG
| otherwise = do
atomically . TM.insert entId d =<< asks dataStore
withLog' dataLog (`logCreateBlob` d)
pure ok
where
d = DataRec {dataId = entId, dataKey, dataBlob}
deleteDataBlob :: M (Transmission BrokerMsg)
deleteDataBlob = do
atomically . TM.delete entId =<< asks dataStore
withLog' dataLog (`logDeleteBlob` entId)
pure ok
getDataBlob :: M (Transmission BrokerMsg)
getDataBlob = case vRes of
VRVerifiedData (Just DataRec {dataBlob}) ->
case thAuth thParams' of
Nothing -> pure $ err $ transportErr TENoServerAuth
Just THAuthServer {serverPrivKey} -> case X25519.publicKey $ unEntityId entId of
CE.CryptoFailed _ -> pure $ err AUTH
CE.CryptoPassed k -> do
let secret = C.dh' (C.PublicKeyX25519 k) serverPrivKey
nonce = C.cbNonce $ bs corrId
THandleParams {thVersion} = thParams'
pure . (corrId,entId,) $
case C.cbEncrypt secret nonce (smpEncode dataBlob) (maxMessageLength thVersion) of
Left _ -> ERR CRYPTO
Right encBlob -> DATA encBlob
_ -> pure $ err INTERNAL
ok :: Transmission BrokerMsg
ok = (corrId, entId, OK)
@@ -1530,9 +1577,11 @@ incStat r = liftIO $ atomicModifyIORef'_ r (+ 1)
{-# INLINE incStat #-}
withLog :: (StoreLog 'WriteMode -> IO a) -> M ()
withLog action = do
env <- ask
liftIO . mapM_ action $ storeLog (env :: Env)
withLog = withLog' storeLog
{-# INLINE withLog #-}
withLog' :: (Env -> Maybe (StoreLog 'WriteMode)) -> (StoreLog 'WriteMode -> IO a) -> M ()
withLog' sel action = liftIO . mapM_ action =<< asks sel
timed :: MonadIO m => T.Text -> RecipientId -> m a -> m a
timed name (EntityId qId) a = do
+62
View File
@@ -0,0 +1,62 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Server.DataLog where
import Control.Applicative ((<|>))
import Control.Monad (foldM)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Simplex.Messaging.Protocol (BlobId)
import Simplex.Messaging.Server.DataStore
import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Util (ifM)
import System.Directory (doesFileExist)
import System.IO
data DataLogRecord = CreateBlob DataRec | DeleteBlob BlobId
instance StrEncoding DataLogRecord where
strEncode = \case
CreateBlob d -> strEncode (Str "CREATE", d)
DeleteBlob dId -> strEncode (Str "DELETE", dId)
strP =
"CREATE " *> (CreateBlob <$> strP)
<|> "DELETE " *> (DeleteBlob <$> strP)
logCreateBlob :: StoreLog 'WriteMode -> DataRec -> IO ()
logCreateBlob s = writeStoreLogRecord s . CreateBlob
logDeleteBlob :: StoreLog 'WriteMode -> BlobId -> IO ()
logDeleteBlob s = writeStoreLogRecord s . DeleteBlob
readWriteDataLog :: FilePath -> IO (Map BlobId DataRec, StoreLog 'WriteMode)
readWriteDataLog f = do
ds <- ifM (doesFileExist f) (readDataBlobs f) (pure M.empty)
s <- openWriteStoreLog f
writeDataBlobs s ds
pure (ds, s)
writeDataBlobs :: StoreLog 'WriteMode -> Map BlobId DataRec -> IO ()
writeDataBlobs = mapM_ . logCreateBlob
readDataBlobs :: FilePath -> IO (Map BlobId DataRec)
readDataBlobs f = foldM processLine M.empty . LB.lines =<< LB.readFile f
where
processLine :: Map BlobId DataRec -> LB.ByteString -> IO (Map BlobId DataRec)
processLine m s' = case strDecode $ trimCR s of
Right r -> pure $ procLogRecord r
Left e -> m <$ printError e
where
s = LB.toStrict s'
procLogRecord :: DataLogRecord -> Map BlobId DataRec
procLogRecord = \case
CreateBlob d -> M.insert (dataId d) d m
DeleteBlob dId -> M.delete dId m
printError :: String -> IO ()
printError e = B.putStrLn $ "Error parsing log: " <> B.pack e <> " - " <> s
+19
View File
@@ -0,0 +1,19 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Messaging.Server.DataStore where
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
data DataRec = DataRec
{ dataId :: BlobId,
dataKey :: DataPublicAuthKey,
dataBlob :: DataBlob
}
instance StrEncoding DataRec where
strEncode DataRec {dataId, dataKey, dataBlob} = strEncode (Str "v1", dataId, dataKey, dataBlob)
strP = do
(dataId, dataKey, dataBlob) <- "v1 " *> strP
pure DataRec {dataId, dataKey, dataBlob}
+20 -3
View File
@@ -31,6 +31,8 @@ import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, new
import Simplex.Messaging.Crypto (KeyHash (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
import Simplex.Messaging.Server.DataLog
import Simplex.Messaging.Server.DataStore
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.MsgStore.STM
@@ -54,6 +56,7 @@ data ServerConfig = ServerConfig
queueIdBytes :: Int,
msgIdBytes :: Int,
storeLogFile :: Maybe FilePath,
dataLogFile :: Maybe FilePath,
storeMsgsFile :: Maybe FilePath,
-- | set to False to prohibit creating new queues
allowNewQueues :: Bool,
@@ -123,8 +126,10 @@ data Env = Env
serverIdentity :: KeyHash,
queueStore :: QueueStore,
msgStore :: STMMsgStore,
dataStore :: TMap BlobId DataRec,
random :: TVar ChaChaDRG,
storeLog :: Maybe (StoreLog 'WriteMode),
dataLog :: Maybe (StoreLog 'WriteMode),
tlsServerParams :: T.ServerParams,
serverStats :: ServerStats,
sockets :: SocketState,
@@ -151,11 +156,13 @@ newtype ProxyAgent = ProxyAgent
type ClientId = Int
data VerificationResult = VRVerified (Maybe QueueRec) | VRVerifiedData (Maybe DataRec) | VRFailed
data Client = Client
{ clientId :: ClientId,
subscriptions :: TMap RecipientId Sub,
ntfSubscriptions :: TMap NotifierId (),
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
rcvQ :: TBQueue (NonEmpty (VerificationResult, Transmission Cmd)),
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
msgQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
procThreads :: TVar Int,
@@ -216,15 +223,20 @@ newProhibitedSub = do
return Sub {subThread = ProhibitSub, delivered}
newEnv :: ServerConfig -> IO Env
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, dataLogFile, smpAgentCfg, transportConfig, information, messageExpiration} = do
server <- newServer
queueStore <- newQueueStore
msgStore <- newMsgStore
dataStore <- TM.emptyIO
random <- C.newRandom
storeLog <-
forM storeLogFile $ \f -> do
logInfo $ "restoring queues from file " <> T.pack f
restoreQueues queueStore f
dataLog <-
forM dataLogFile $ \f -> do
logInfo $ "restoring data blobs from file " <> T.pack f
restoreDataBlobs dataStore f
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
Fingerprint fp <- loadFingerprint caCertificateFile
let serverIdentity = KeyHash fp
@@ -233,7 +245,7 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
clientSeq <- newTVarIO 0
clients <- newTVarIO mempty
proxyAgent <- newSMPProxyAgent smpAgentCfg random
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, random, storeLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
pure Env {config, serverInfo, server, serverIdentity, queueStore, msgStore, dataStore, random, storeLog, dataLog, tlsServerParams, serverStats, sockets, clientSeq, clients, proxyAgent}
where
restoreQueues :: QueueStore -> FilePath -> IO (StoreLog 'WriteMode)
restoreQueues QueueStore {queues, senders, notifiers} f = do
@@ -242,6 +254,11 @@ newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile,
atomically $ writeTVar senders $! M.foldr' addSender M.empty qs
atomically $ writeTVar notifiers $! M.foldr' addNotifier M.empty qs
pure s
restoreDataBlobs :: TMap BlobId DataRec -> FilePath -> IO (StoreLog 'WriteMode)
restoreDataBlobs dataStore f = do
(ds, s) <- readWriteDataLog f
atomically $ writeTVar dataStore ds
pure s
addSender :: QueueRec -> Map SenderId RecipientId -> Map SenderId RecipientId
addSender q = M.insert (senderId q) (recipientId q)
addNotifier :: QueueRec -> Map NotifierId RecipientId -> Map NotifierId RecipientId
+2
View File
@@ -79,6 +79,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
defaultServerPort = "5223"
executableName = "smp-server"
storeLogFilePath = combine logPath "smp-server-store.log"
dataLogFilePath = combine logPath "smp-server-data.log"
httpsCertFile = combine cfgPath "web.cert"
httpsKeyFile = combine cfgPath "web.key"
defaultStaticPath = combine logPath "www"
@@ -262,6 +263,7 @@ smpServerCLI_ generateSite serveStaticFiles cfgPath logPath =
privateKeyFile = c serverKeyFile,
certificateFile = c serverCrtFile,
storeLogFile = enableStoreLog $> storeLogFilePath,
dataLogFile = enableStoreLog $> dataLogFilePath,
storeMsgsFile =
let messagesPath = combine logPath "smp-server-messages.log"
in case iniOnOff "STORE_LOG" "restore_messages" ini of
+10 -3
View File
@@ -47,6 +47,7 @@ module Simplex.Messaging.Transport
authCmdsSMPVersion,
sendingProxySMPVersion,
sndAuthKeySMPVersion,
dataBlobSMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -130,6 +131,9 @@ smpBlockSize = 16384
-- 5 - basic auth for SMP servers (11/12/2022)
-- 6 - allow creating queues without subscribing (9/10/2023)
-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (4/30/2024)
-- 8 - forwarding proxy protecting IP addresses and sessions of command senders (5/14/2024)
-- 9 - securing message queue by sender (SKEY command) for faster connection handshake (6/30/2024)
-- 10 - storing data blobs on SMP servers for short invitation links (7/25/2024)
data SMPVersion
@@ -160,14 +164,17 @@ sendingProxySMPVersion = VersionSMP 8
sndAuthKeySMPVersion :: VersionSMP
sndAuthKeySMPVersion = VersionSMP 9
dataBlobSMPVersion :: VersionSMP
dataBlobSMPVersion = VersionSMP 10
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 9
currentClientSMPRelayVersion = VersionSMP 10
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 9
currentServerSMPRelayVersion = VersionSMP 10
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
@@ -175,7 +182,7 @@ currentServerSMPRelayVersion = VersionSMP 9
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 9
proxiedSMPRelayVersion = VersionSMP 10
-- minimal supported protocol version is 4
-- TODO remove code that supports sending commands without batching
+1 -1
View File
@@ -166,7 +166,7 @@ testNtfMatrix t runTest = do
it "curr servers; curr clients" $ runNtfTestCfg t 1 cfg ntfServerCfg agentCfg agentCfg runTest
it "curr servers; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "prev servers; curr clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
it "prev servers; curr clients" $ runNtfTestCfg t 1 cfgVPrev ntfServerCfgVPrev agentCfg agentCfg runTest
-- servers can be upgraded in any order
it "servers: curr SMP, prev NTF; prev clients" $ runNtfTestCfg t 3 cfg ntfServerCfgVPrev agentCfgVPrevPQ agentCfgVPrevPQ runTest
it "servers: prev SMP, curr NTF; prev clients" $ runNtfTestCfg t 3 cfgVPrev ntfServerCfg agentCfgVPrevPQ agentCfgVPrevPQ runTest
+5 -1
View File
@@ -57,6 +57,9 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
testStoreLogFile2 :: FilePath
testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
testDataLogFile :: FilePath
testDataLogFile = "tests/tmp/smp-server-data.log"
testStoreMsgsFile :: FilePath
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
@@ -104,6 +107,7 @@ cfg =
queueIdBytes = 24,
msgIdBytes = 24,
storeLogFile = Nothing,
dataLogFile = Nothing,
storeMsgsFile = Nothing,
allowNewQueues = True,
newQueueBasicAuth = Nothing,
@@ -159,7 +163,7 @@ withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasC
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, dataLogFile = Just testDataLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerConfigOn t cfg' port' =
+70 -1
View File
@@ -19,6 +19,9 @@ import Control.Concurrent (ThreadId, threadDelay)
import Control.Logger.Simple
import Control.Monad (forM, forM_, forever, replicateM_)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Crypto.Hash (SHA512)
import qualified Crypto.KDF.HKDF as H
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as L
@@ -34,7 +37,7 @@ import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, maxMessageLength, noMsgFlags)
import Simplex.Messaging.Protocol (DataBlob (..), EntityId (..), EncRcvMsgBody (..), MsgBody, RcvMessage (..), SubscriptionMode (..), pattern NoEntity, e2eEncConfirmationLength, maxMessageLength, noMsgFlags)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
import Simplex.Messaging.Transport
@@ -133,6 +136,25 @@ smpProxyTests = do
xdescribe "stress test 10k" $ do
let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
describe "receive data blobs via SMP proxy" $ do
let srv1 = SMPServer testHost testPort testKeyHash
srv2 = SMPServer testHost testPort2 testKeyHash
describe "client API" $ do
describe "one server" $ do
it "deliver via proxy" . oneServer $ do
receiveBlobViaProxy srv1 srv1 C.SEd448 "hello"
describe "two servers" $ do
let proxyServ = srv1
relayServ = srv2
blob <- runIO $ atomically . C.randomBytes (e2eEncConfirmationLength - 2) =<< C.newRandom
it "deliver via proxy" . twoServersFirstProxy $
receiveBlobViaProxy proxyServ relayServ C.SEd448 "hello"
it "max blob size, Ed448 keys" . twoServersFirstProxy $
receiveBlobViaProxy proxyServ relayServ C.SEd448 blob
it "max blob size, Ed25519 keys" . twoServersFirstProxy $
receiveBlobViaProxy proxyServ relayServ C.SEd25519 blob
it "max blob size, X25519 keys" . twoServersFirstProxy $
receiveBlobViaProxy proxyServ relayServ C.SX25519 blob
where
oneServer = withSmpServerConfigOn (transport @TLS) proxyCfg {msgQueueQuota = 128} testPort . const
twoServers = twoServers_ proxyCfg proxyCfg
@@ -404,6 +426,53 @@ agentViaProxyRetryNoSession = do
withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfg {storeLogFile = Just testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2} testPort2
servers srv = (initAgentServersProxy SPMAlways SPFProhibit) {smp = userServers [srv]}
receiveBlobViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> IO ()
receiveBlobViaProxy proxyServ relayServ alg origData = do
g <- C.newRandom
-- proxy client
pc' <- getProtocolClient g (1, proxyServ, Nothing) defaultSMPClientConfig Nothing (\_ -> pure ())
pc <- either (fail . show) pure pc'
THAuthClient {} <- maybe (fail "getProtocolClient returned no thAuth") pure $ thAuth $ thParams pc
-- relay client
rc' <- getProtocolClient g (2, relayServ, Nothing) defaultSMPClientConfig Nothing (\_ -> pure ())
rc <- either (fail . show) pure rc'
-- prepare blob
-- k: ID to retrive blob.
-- pk: part of the link sent to the accepting party (Sender role),
-- also key material for HKDF to derive key to e2e encrypt blob.
-- hash(k): ID used to store blob
-- (k, pk): used to agree additional server-to-client encryption when retrieving blob,
-- using DH with server session keys.
(C.PublicKeyX25519 k, pk'@(C.PrivateKeyX25519 pk _)) <- atomically $ C.generateKeyPair @'C.X25519 g
blobKeys@(_, blobPKey) <- atomically $ C.generateAuthKeyPair alg g
let kBytes = BA.convert k :: ByteString -- blob ID for "sender" (blob recipient)
rBlobId = EntityId $ C.sha256Hash kBytes
pkBytes = BA.convert pk :: ByteString
ikm = pkBytes
salt = "" :: ByteString
info = "SimpleXDataBlob" :: ByteString
prk = H.extract salt ikm :: H.PRK SHA512
skBytes = H.expand prk info 32
dataNonce <- atomically $ C.randomCbNonce g
Right sk <- pure $ C.sbKey skBytes
-- store blob
Right dataBody <- pure $ C.sbEncrypt sk dataNonce origData e2eEncConfirmationLength
let blob = DataBlob {dataNonce, dataBody}
runRight_ $ do
createSMPDataBlob rc blobKeys rBlobId blob
-- retrive blob directly
blob1@DataBlob {dataNonce = dataNonce1, dataBody = body1} <- getSMPDataBlob rc pk'
liftIO $ blob1 `shouldBe` blob
liftIO $ C.sbDecrypt sk dataNonce1 body1 `shouldBe` Right origData
-- retrive blob via proxy
sess <- connectSMPProxiedRelay pc relayServ (Just "correct")
Right blob2 <- proxyGetSMPDataBlob pc sess pk'
liftIO $ blob2 `shouldBe` blob
-- delete blob
deleteSMPDataBlob rc blobPKey rBlobId
liftIO $ runExceptT (getSMPDataBlob rc pk') `shouldReturn` Left (PCEProtocolError SMP.AUTH)
liftIO $ runExceptT (proxyGetSMPDataBlob pc sess pk') `shouldReturn` Left (PCEProtocolError SMP.AUTH)
testNoProxy :: IO ()
testNoProxy = do
withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
+127
View File
@@ -21,7 +21,10 @@ import Control.Concurrent.STM
import Control.Exception (SomeException, try)
import Control.Monad
import Control.Monad.IO.Class
import Crypto.Hash (SHA512)
import qualified Crypto.KDF.HKDF as H
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@@ -69,6 +72,9 @@ serverTests t@(ATransport t') = do
testMsgExpireOnSend t'
testMsgExpireOnInterval t'
testMsgNOTExpireOnInterval t'
describe "Data blobs" $ do
testDataBlobs t'
testDataBlobsWithLog t
pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
@@ -915,6 +921,127 @@ testMsgNOTExpireOnInterval t =
Nothing -> return ()
Just _ -> error "nothing else should be delivered"
testDataBlobs :: forall c. Transport c => TProxy c -> Spec
testDataBlobs t =
it "should store, retrieve, update and delete data blob directly from the server" $
smpTest2 t $ \r s -> do
g <- C.newRandom
-- k: ID to retrive blob.
-- pk: part of the link sent to the accepting party (Sender role),
-- also key material for HKDF to derive key to e2e encrypt blob.
-- hash(k): ID used to store blob
-- (k, pk): used to agree additional server-to-client encryption when retrieving blob,
-- using DH with server session keys.
(C.PublicKeyX25519 k, pk'@(C.PrivateKeyX25519 pk _)) <- atomically $ C.generateKeyPair @'C.X25519 g
(blobKey, blobPKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let kBytes = BA.convert k :: ByteString
rBlobId = EntityId $ C.sha256Hash kBytes
sBlobId = EntityId $ kBytes
pkBytes = BA.convert pk :: ByteString
ikm = pkBytes
salt = "" :: ByteString
info = "SimpleXDataBlob" :: ByteString
prk = H.extract salt ikm :: H.PRK SHA512
skBytes = H.expand prk info 32
origData = "hello"
origData2 = "hello 2"
dataNonce <- atomically $ C.randomCbNonce g
Right sk <- pure $ C.sbKey skBytes
-- store and retrieve blob
Right dataBody <- pure $ C.sbEncrypt sk dataNonce origData e2eEncConfirmationLength
let blob = DataBlob {dataNonce, dataBody}
-- storing data signed with the incorrect key fails (not matching key in command)
(_, blobPKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
Resp "0" _ (ERR AUTH) <- signSendRecv r blobPKey' ("0", rBlobId, WRT blobKey blob)
-- correct key succeeds
Resp "1" _ OK <- signSendRecv r blobPKey ("1", rBlobId, WRT blobKey blob)
Resp "2" _ (DATA encBlob) <- sendRecv s ("", "2", sBlobId, READ)
THandle {params = THandleParams {thAuth = Just THAuthClient {serverPeerPubKey}}} <- pure s
let ss = C.dh' serverPeerPubKey pk'
respNonce = C.cbNonce "2" -- correlation ID sent in READ request
Right blobStr <- pure $ C.cbDecrypt ss respNonce encBlob
Right blob'@DataBlob {dataNonce = dataNonce', dataBody = body'} <- pure $ smpDecode blobStr
blob' `shouldBe` blob
Right origData' <- pure $ C.sbDecrypt sk dataNonce' body'
origData' `shouldBe` origData
-- update and retrieve blob
dataNonce2 <- atomically $ C.randomCbNonce g
Right dataBody2 <- pure $ C.sbEncrypt sk dataNonce2 origData2 e2eEncConfirmationLength
let blob2 = DataBlob {dataNonce = dataNonce2, dataBody = dataBody2}
-- storing data under the same ID but signed with the different key fails (even if it matches key in command)
(blobKey'', blobPKey'') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
Resp "3" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("3", rBlobId, WRT blobKey'' blob2)
-- same key but signed with the wrong key also fails
Resp "4" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("4", rBlobId, WRT blobKey blob2)
-- same key bsucceeds
Resp "5" _ OK <- signSendRecv r blobPKey ("5", rBlobId, WRT blobKey blob2)
Resp "6" _ (DATA encBlob2) <- sendRecv s ("", "6", sBlobId, READ)
let respNonce2 = C.cbNonce "6" -- correlation ID sent in READ request
Right blobStr2 <- pure $ C.cbDecrypt ss respNonce2 encBlob2
Right blob2'@DataBlob {dataNonce = dataNonce2', dataBody = body2'} <- pure $ smpDecode blobStr2
blob2' `shouldBe` blob2
Right origData2' <- pure $ C.sbDecrypt sk dataNonce2' body2'
origData2' `shouldBe` origData2
-- remove data blob
-- incorrect ID fails
Resp "7" _ (ERR AUTH) <- signSendRecv r blobPKey ("7", sBlobId, CLR)
-- incorrect key fails
Resp "8" _ (ERR AUTH) <- signSendRecv r blobPKey'' ("8", rBlobId, CLR)
Resp "9" _ (DATA encBlob2') <- sendRecv s ("", "9", sBlobId, READ)
encBlob2' `shouldBe` encBlob2'
-- correct key and ID succeed
Resp "10" _ OK <- signSendRecv r blobPKey ("10", rBlobId, CLR)
Resp "11" _ (ERR AUTH) <- sendRecv s ("", "11", sBlobId, READ)
pure ()
testDataBlobsWithLog :: ATransport -> Spec
testDataBlobsWithLog at@(ATransport t) =
it "should store data blob to log and restore after server restart" $ do
g <- C.newRandom
(C.PublicKeyX25519 k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g
(blobKey, blobPKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
dataNonce <- atomically $ C.randomCbNonce g
let kBytes = BA.convert k :: ByteString
rBlobId = EntityId $ C.sha256Hash kBytes
sBlobId = EntityId $ kBytes
blob = DataBlob {dataNonce, dataBody = "some random encrypted data"} -- the previous test shows e2e blob encryption
blob2 = DataBlob {dataNonce, dataBody = "some other encrypted data"}
clientServer t $ \h -> do
Resp "1" _ OK <- signSendRecv h blobPKey ("1", rBlobId, WRT blobKey blob)
pure ()
clientServer t $ \h -> do
testGetBlob h "2" pk sBlobId blob
-- update blob
Resp "3" _ OK <- signSendRecv h blobPKey ("3", rBlobId, WRT blobKey blob2)
testGetBlob h "4" pk sBlobId blob2
clientServer t $ \h -> do
-- updated after restart
testGetBlob h "5" pk sBlobId blob2
-- delete blob
Resp "6" _ OK <- signSendRecv h blobPKey ("6", rBlobId, CLR)
Resp "7" _ (ERR AUTH) <- sendRecv h ("", "7", sBlobId, READ)
pure ()
clientServer t $ \h -> do
-- deleted after restart
Resp "8" _ (ERR AUTH) <- sendRecv h ("", "8", sBlobId, READ)
pure ()
where
clientServer :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> IO ()
clientServer _ test' =
withSmpServerStoreLogOn at testPort $ \server -> do
testSMPClient test' `shouldReturn` ()
killThread server
testGetBlob h corrId pk sBlobId expectedBlob = do
Resp (CorrId corrId') _ (DATA encBlob) <- sendRecv h ("", corrId, sBlobId, READ)
corrId' `shouldBe` corrId
THandle {params = THandleParams {thAuth = Just THAuthClient {serverPeerPubKey}}} <- pure h
let ss = C.dh' serverPeerPubKey pk
respNonce = C.cbNonce corrId -- correlation ID sent in READ request
Right blobStr <- pure $ C.cbDecrypt ss respNonce encBlob
Right blob' <- pure $ smpDecode blobStr
blob' `shouldBe` expectedBlob
samplePubKey :: C.APublicVerifyKey
samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="