mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 16:15:12 +00:00
smp protocol: short links and other changes from RFC (#1489)
* smp protocol: short links types and other changes from RFC * add fields for queue link ID and data * create queue and ntf credentials with NEW command * all tests * simplfiy types, update rfc * update rfc * include SenderId in NEW request in case queue data is sent * store queue data and generate link ID if needed * update rfc * agent API and types * SMP commands and persistence for short links * SMP client functions for short links * agent client functions for short links * create rcv queue with short link (TODO secret_box) * encryption and encoding for link data, postgres client migration * test creating short link * get link and data, tests * comments * type signature
This commit is contained in:
@@ -65,36 +65,32 @@ Proposed NEW command replaces SenderCanSecure with QueueMode, adds link data, an
|
||||
```haskell
|
||||
NEW :: NewQueueRequest -> Command Recipient
|
||||
|
||||
data NewQueueRequest = NewQueueRequest
|
||||
data NewQueueReq = NewQueueReq
|
||||
{ rcvAuthKey :: RcvPublicAuthKey,
|
||||
rcvDhKey :: RcvPublicDhKey,
|
||||
basicAuth :: Maybe BasicAuth,
|
||||
auth_ :: Maybe BasicAuth,
|
||||
subMode :: SubscriptionMode,
|
||||
ntfRequest :: Maybe NtfRequest,
|
||||
queueLink :: Maybe QueueLink -- it is Maybe to allow testing and staged roll-out
|
||||
queueData :: Maybe QueueReqData,
|
||||
ntfCreds :: Maybe NewNtfCreds
|
||||
}
|
||||
|
||||
-- To allow updating the existing contact addresses without changing them.
|
||||
-- This command would fail on queues that support sndSecure and also on new queues created with QLMessaging.
|
||||
-- RecipientId is entity ID.
|
||||
-- The response to this command is `OK`.
|
||||
LNEW :: LinkId -> QueueLinkData -> Command Recipient
|
||||
|
||||
-- Replaces NKEY command
|
||||
-- This avoids additional command required from the client to enable notifications.
|
||||
-- Further changes would move NotifierId generation to the client, and including a signed and encrypted command to be forwarded by SMP server to notification server.
|
||||
data NtfRequest = NtfRequest NtfPublicAuthKey RcvNtfPublicDhKey
|
||||
|
||||
-- QLMessaging implies that sender can secure the queue.
|
||||
-- LinkId is not used with QLMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used.
|
||||
-- LinkId is required with QLContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists.
|
||||
data QueueLink = QLMessaging QueueLinkData | QLContact LinkId QueueLinkData
|
||||
-- QRMessaging implies that sender can secure the queue.
|
||||
-- LinkId is not used with QRMessaging, to prevent the possibility of checking when connection is established by re-using the same link ID when creating another queue – the creating would have to fail if it is used.
|
||||
-- LinkId is required with QRContact, to have shorter link - it will be derived from the link_uri. And in this case we do not need to prevent checks that this queue exists.
|
||||
data QueueReqData = QRMessaging (Maybe QueueLinkData) | QRContact (Maybe (LinkId, QueueLinkData))
|
||||
|
||||
data QueueLinkData = QueueLinkData EncImmutableDataBytes EncUserDataBytes
|
||||
-- SenderId should be computed client-side as sha3-256(correlation_id),
|
||||
-- The server must verify it and reject if it is not.
|
||||
type QueueLinkData = (SenderId, EncImmutableDataBytes, EncUserDataBytes)
|
||||
|
||||
newtype EncImmutableDataBytes = EncImmutableDataBytes ByteString
|
||||
type EncImmutableDataBytes = ByteString
|
||||
|
||||
newtype EncUserDataBytes = EncUserDataBytes ByteString
|
||||
type EncUserDataBytes = ByteString
|
||||
|
||||
-- We need to use binary encoding for AConnectionRequestUri to reduce its size
|
||||
-- connReq including the full link allows connection redundancy.
|
||||
@@ -128,27 +124,45 @@ data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey -- NotifierId
|
||||
In addition to that we add the command allowing to update and also to retrieve and, optionally, secure the queue and get link data in one request, to have only one request:
|
||||
|
||||
```haskell
|
||||
-- With RecipientId as entity ID, the command to update mutable part of link data
|
||||
-- The response is OK here.
|
||||
LSET :: EncUserDataBytes -> Command Recipient
|
||||
-- This command allows to set all data or to update mutlable part of contact address queue.
|
||||
-- This command should fail on queues that support sndSecure and also on new queues created with QRMessaging.
|
||||
-- This should fail if LinkId or immutable part of data is changed with the update, but will succeed if only mutable part is updated, so it can be retried.
|
||||
-- Entity ID is RecipientId.
|
||||
-- The response to this command is `OK`.
|
||||
LSET :: LinkId -> QueueLinkData -> Command Recipient
|
||||
|
||||
-- Delete should link and associated data
|
||||
-- Entity ID is RecipientId
|
||||
LDEL :: Command Recipient
|
||||
|
||||
-- To be used with 1-time links.
|
||||
-- Sender's key provided on the first request prevents observers from undetectably accessing 1-time link data.
|
||||
-- If queue mode is QLContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY.
|
||||
-- If queue mode is QRContact (and queue does NOT allow sndSecure) the command will fail, same as SKEY.
|
||||
-- Once queue is secured, the key must be the same in subsequent requests - to allow retries in case of network failures, and to prevent passive attacks.
|
||||
-- The difference with securing queues is that queues allow sending unsecured messages to queues that allow sndSecure (for backwards compatibility), and 1-time links will NOT allow retrieving link data without securing the queue at the same time, preventing undetected access by observers.
|
||||
-- Entity ID is LinkId here
|
||||
-- Entity ID is LinkId
|
||||
LKEY :: SndPublicAuthKey -> Command Sender
|
||||
|
||||
-- If queue mode is QLMessaging the command will fail.
|
||||
-- Entity ID is LinkId here
|
||||
-- If queue mode is QRMessaging the command will fail.
|
||||
-- Entity ID is LinkId
|
||||
LGET :: Command Sender
|
||||
|
||||
-- Response to LKEY and LGET
|
||||
-- Entity ID is LinkId here
|
||||
LINK :: SenderId -> QueueLinkData -> BrokerMsg
|
||||
-- Response to LGET, LSKEY and LSGET
|
||||
-- Entity ID is the same as in the command
|
||||
LNK :: SenderId -> QueueLinkData -> BrokerMsg
|
||||
```
|
||||
|
||||
To both include sender_id into the full link before the server response, and to prevent "oracle attack" when a failure to create the queue with the supplied `sender_id` can be used as a proof of queue existense, it is proposed that `sender_id` is computed client-side as `sha3-256(correlation_id)` and validated server-side, where `corelation_id` is the transmission correlation ID.
|
||||
|
||||
To allow retries and to avoid regenerating all queue data, NEW command must be idempotent, and `correlation_id` must be preserved in command for queue creation, so that the same `correlation_id` and all other data is used in retries. `correlation_id` should be removed after queue creation success.
|
||||
|
||||
To allow retries, every time the command is sent a new random `correlation_id` and new `sender_id` / `link_id` should be used on each attempt, because other IDs would be generated randomly on the server, and in case the previous command succeeded on the server but failed to be communicated to the client, the retry will fail if the same ID is used.
|
||||
|
||||
Alternative solutions considered and rejected:
|
||||
- additional request to save queue data, after `sender_id` is returned by the server. The scenarios that require short links are interactive - creating user addresses and 1-time invitations - so making two requests instead of one would make the UX worse.
|
||||
- include empty sender_id in the immutable data and have it replaced by the accepting party with `sender_id` received in `LINK` response - both a weird design, and might create possibility for some attacks via server, especially for contact addresses.
|
||||
- making NEW commands idempotent. Doing it would require generating all IDs client-side, not only `sender_id`. It increases complexity, and it is not really necessary as the only scenarios when retries are needed are async NEW commands, that do not require short links. For future short links of chat relays the retries are much less likely, as chat relays will have good network connections.
|
||||
|
||||
## Algorithm to prepare and to interpret queue link data.
|
||||
|
||||
For contact addresses this approach follows the design proposed in [Short links](./2024-06-21-short-links.md) RFC - when link id is derived from the same random binary as key. For 1-time invitations link ID is independent and server-generated, to prevent existense checks.
|
||||
@@ -166,6 +180,42 @@ For contact addresses this approach follows the design proposed in [Short links]
|
||||
- for one time links the sender must authorize the request to retrieve the data, the key is provided with the first request, preventing undetected access by link observers.
|
||||
- having received the link data, the client can now decrypt it using secret_box.
|
||||
|
||||
## Improved algorithm to prepare and to interpret queue link data.
|
||||
|
||||
This scheme reduces the size of the binary in the link from 48 bytes (72 in case of 1-time links) to 32 bytes (56 bytes for 1-time links).
|
||||
|
||||
For immutable data.
|
||||
|
||||
1. `link_key = SHA3-256(immutable_data)` - used as part of link, and to encrypt content.
|
||||
2. HKDF:
|
||||
1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
|
||||
2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`, `link-id` - server-generated.
|
||||
3.
|
||||
3. Random `nonce1` (for immutable data), to be stored with the link data.
|
||||
4. Encrypt: `(ct1, tag1) = secret_box(immutable_data, key, nonce1)`.
|
||||
5. Store: `(nonce1, ct1, tag1)` stored as immutable link data.
|
||||
|
||||
For mutable user data:
|
||||
|
||||
1. Random `nonce2` and the same key are used.
|
||||
2. Sign `user_data` with key included in `immutable_data`.
|
||||
3. Encrypt: `(ct2, tag2) = secret_box(signed_used_data, key, nonce2)`.
|
||||
4. Store: `(nonce2, ct2, tag2)`
|
||||
|
||||
Link recipient:
|
||||
|
||||
1. Receives `link_key` in the link, for 1-time invitations also `link_id`.
|
||||
2. HKDF:
|
||||
1) contact address: `(link_id, key) = HKDF(link_key, 56 bytes)`.
|
||||
2) 1-time invitation: `key = HKDF(link_key, 32 bytes)`.
|
||||
3. Retrieves via `link_id`: `(nonce1, ct1, tag1)` and `(nonce2, ct2, tag2)`.
|
||||
4. Decrypt: `immutable_data = decrypt (nonce1, ct1, tag1)`.
|
||||
5. Verify: `SHA3-256(immutable_data) == link_key`, abort if not.
|
||||
6. Decrypt: `signed_used_data = decrypt(nonce2, ct2, tag2)`
|
||||
7. Verify signature with key in immutable data.
|
||||
|
||||
While using content hash as encryption key is unconventional, it is not completely unheard of - e.g., it is used in convergent encryption (although in our case using random nonce makes it not convergent, but other use cases suggest that this approach preserves encryption security). It is particularly acceptable for our use case, as `immutable_data` contains mostly random keys.
|
||||
|
||||
## Threat model
|
||||
|
||||
**Compromised SMP server**
|
||||
@@ -214,11 +264,10 @@ The proposed syntax:
|
||||
shortConnectionLink = %s"https://" smpServerHost "/" linkUri [ "?" param *( "&" param ) ]
|
||||
smpServerHost = <hostname> ; RFC1123, RFC5891
|
||||
linkUri = %s"i#" serverInfo oneTimeLinkBytes / %s"c#" serverInfo contactLinkBytes
|
||||
oneTimeLinkBytes = <base64url(linkId | linkKey | linkAuthTag)> ; 60 bytes / 80 base64 encoded characters
|
||||
contactLinkBytes = <base64url(linkKey | linkAuthTag)> ; 48 bytes / 64 base64 encoded characters
|
||||
oneTimeLinkBytes = <base64url(linkId | linkKey)> ; 56 bytes / 75 base64 encoded characters
|
||||
contactLinkBytes = <base64url(linkKey)> ; 32 bytes / 43 base64 encoded characters
|
||||
; linkId - 96 bits/24 bytes
|
||||
; linkKey - 256 bits/32 bytes
|
||||
; linkAuthTag - 128 bits/16 bytes auth tag from encryption of immutable link data>
|
||||
|
||||
serverInfo = [fingerprint "@" [hostnames "/"]] ; not needed for preset servers, required otherwise - the clients must refuse to connect if they don't have fingerprint in the code.
|
||||
|
||||
@@ -228,28 +277,28 @@ hostnames = "h=" <hostname> *( "," <hostname> ) ; additional hostnames, e.g. oni
|
||||
|
||||
To have shorter links fingerpring and additional server hostnames do not need to be specified for preconfigured servers, even if they are disabled - they can be used from the client code. Any user defined servers will require including additional hosts and server fingerprint.
|
||||
|
||||
Example one-time link for preset server (108 characters):
|
||||
Example one-time link for preset server (103 characters):
|
||||
|
||||
```
|
||||
https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789
|
||||
https://smp12.simplex.im/i#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcdefghij01234
|
||||
```
|
||||
|
||||
Example contact link for preset server (92 characters):
|
||||
Example contact link for preset server (71 characters):
|
||||
|
||||
```
|
||||
https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
|
||||
https://smp12.simplex.im/c#abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
Example contact link for user-defined server (with fingerprint, but without onion hostname - 136 characters):
|
||||
Example contact link for user-defined server (with fingerprint, but without onion hostname - 115 characters):
|
||||
|
||||
```
|
||||
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
|
||||
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
Example contact link for user-defined server (with fingerprint ant onion hostname - 199 characters):
|
||||
Example contact link for user-defined server (with fingerprint ant onion hostname - 178 characters):
|
||||
|
||||
```
|
||||
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abcdefghij0123456789abcd
|
||||
https://smp1.example.com/c#0YuTwO05YJWS8rkjn9eLJDjQhFKvIYd8d4xG8X1blIU@beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion/abcdefghij0123456789abcdefghij0123456789abc
|
||||
```
|
||||
|
||||
For the links to work in the browser the servers must provide server pages.
|
||||
|
||||
@@ -121,6 +121,7 @@ library
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.FFI
|
||||
Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG
|
||||
Simplex.Messaging.Crypto.ShortLink
|
||||
Simplex.Messaging.Encoding
|
||||
Simplex.Messaging.Encoding.String
|
||||
Simplex.Messaging.Notifications.Client
|
||||
@@ -158,6 +159,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.App
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
|
||||
Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
|
||||
else
|
||||
exposed-modules:
|
||||
Simplex.Messaging.Agent.Store.SQLite
|
||||
@@ -203,6 +205,7 @@ library
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
|
||||
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
|
||||
if !flag(client_library)
|
||||
exposed-modules:
|
||||
Simplex.FileTransfer.Client.Main
|
||||
@@ -366,6 +369,8 @@ executable ntf-server
|
||||
executable smp-server
|
||||
if flag(client_library)
|
||||
buildable: False
|
||||
if flag(server_postgres)
|
||||
cpp-options: -DdbServerPostgres
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Static
|
||||
@@ -441,6 +446,7 @@ test-suite simplexmq-test
|
||||
AgentTests.MigrationTests
|
||||
AgentTests.NotificationTests
|
||||
AgentTests.ServerChoice
|
||||
AgentTests.ShortLinkTests
|
||||
CLITests
|
||||
CoreTests.BatchingTests
|
||||
CoreTests.CryptoFileTests
|
||||
|
||||
+140
-28
@@ -56,6 +56,7 @@ module Simplex.Messaging.Agent
|
||||
deleteConnectionAsync,
|
||||
deleteConnectionsAsync,
|
||||
createConnection,
|
||||
getConnShortLink,
|
||||
changeConnectionUser,
|
||||
prepareConnectionToJoin,
|
||||
prepareConnectionToAccept,
|
||||
@@ -181,13 +182,14 @@ import Simplex.Messaging.Client (SMPClientError, ServerTransmission (..), Server
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
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.ShortLink as SL
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfRegCode), NtfTknStatus (..), NtfTokenId, PNMessageData (..), pnMessagesP)
|
||||
import Simplex.Messaging.Notifications.Types
|
||||
import Simplex.Messaging.Parsers (parse)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC, sndAuthKeySMPClientVersion)
|
||||
import Simplex.Messaging.Protocol (BrokerMsg, Cmd (..), ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI (..), SMPMsgMeta, SParty (..), SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, VersionSMPC)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
@@ -340,10 +342,27 @@ deleteConnectionsAsync c waitDelivery = withAgentEnv c . deleteConnectionsAsync'
|
||||
{-# INLINE deleteConnectionsAsync #-}
|
||||
|
||||
-- | Create SMP agent connection (NEW command)
|
||||
createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs = withAgentEnv c .:: newConn c userId enableNtfs
|
||||
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AE (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
|
||||
createConnection c userId enableNtfs = withAgentEnv c .::. newConn c userId enableNtfs
|
||||
{-# INLINE createConnection #-}
|
||||
|
||||
-- | Create or update user's contact connection short link
|
||||
-- TODO [short links]
|
||||
setConnShortLink :: AgentClient -> ConnId -> ConnInfo -> AE (ConnShortLink 'CMContact)
|
||||
setConnShortLink c = withAgentEnv c .: setConnShortLink' c
|
||||
{-# INLINE setConnShortLink #-}
|
||||
|
||||
-- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries
|
||||
getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo)
|
||||
getConnShortLink c = withAgentEnv c .: getConnShortLink' c
|
||||
{-# INLINE getConnShortLink #-}
|
||||
|
||||
-- | This irreversible deletes short link data, and it won't be retrievable again
|
||||
-- TODO [short links]
|
||||
delInvShortLink :: AgentClient -> ConnShortLink 'CMInvitation -> AE ()
|
||||
delInvShortLink c = withAgentEnv c . delInvShortLink' c
|
||||
{-# INLINE delInvShortLink #-}
|
||||
|
||||
-- | Changes the user id associated with a connection
|
||||
changeConnectionUser :: AgentClient -> UserId -> ConnId -> UserId -> AE ()
|
||||
changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConnectionUser' c oldUserId connId newUserId
|
||||
@@ -776,12 +795,45 @@ switchConnectionAsync' c corrId connId =
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
|
||||
|
||||
newConn :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, ConnectionRequestUri c)
|
||||
newConn c userId enableNtfs cMode clientData pqInitKeys subMode = do
|
||||
newConn :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> AM (ConnId, (ConnectionRequestUri c, Maybe (ConnShortLink c)))
|
||||
newConn c userId enableNtfs cMode userData_ clientData pqInitKeys subMode = do
|
||||
srv <- getSMPServer c userId
|
||||
connId <- newConnNoQueues c userId enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
cReq <- newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
|
||||
pure (connId, cReq)
|
||||
(connId,) <$> newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srv
|
||||
`catchE` \e -> withStore' c (`deleteConnRecord` connId) >> throwE e
|
||||
|
||||
setConnShortLink' :: AgentClient -> ConnId -> ConnInfo -> AM (ConnShortLink 'CMContact)
|
||||
setConnShortLink' = undefined
|
||||
|
||||
getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo)
|
||||
getConnShortLink' c userId = \case
|
||||
CSLInvitation srv linkId linkKey -> do
|
||||
g <- asks random
|
||||
invLink <- withStore' c $ \db -> do
|
||||
getInvShortLink db srv linkId >>= \case
|
||||
Just sl@InvShortLink {linkKey = lk} | linkKey == lk -> pure sl
|
||||
_ -> do
|
||||
(sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
let sl = InvShortLink {server = srv, linkId, linkKey, sndPrivateKey, sndPublicKey}
|
||||
createInvShortLink db sl
|
||||
pure sl
|
||||
let k = SL.invShortLinkKdf linkKey
|
||||
secureGetQueueLink c userId invLink >>= decryptData srv linkKey k
|
||||
CSLContact srv _ linkKey -> do
|
||||
let (linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
getQueueLink c userId srv linkId >>= decryptData srv linkKey k
|
||||
where
|
||||
decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, SMP.QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo)
|
||||
decryptData srv linkKey k (sndId, d) = do
|
||||
r <- liftEither $ SL.decryptLinkData @c linkKey k d
|
||||
checkSameQueue $ case fst r of CRInvitationUri crd _ -> crd; CRContactUri crd -> crd
|
||||
pure r
|
||||
where
|
||||
checkSameQueue ConnReqUriData {crSmpQueues = SMPQueueUri {queueAddress = SMPQueueAddress srv' sndId' _ _} :| _} =
|
||||
unless (srv == srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address"
|
||||
|
||||
delInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM ()
|
||||
delInvShortLink' = undefined
|
||||
|
||||
changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
|
||||
changeConnectionUser' c oldUserId connId newUserId = do
|
||||
@@ -793,28 +845,86 @@ changeConnectionUser' c oldUserId connId newUserId = do
|
||||
where
|
||||
updateConn = withStore' c $ \db -> setConnUserId db oldUserId connId newUserId
|
||||
|
||||
newRcvConnSrv :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
newRcvConnSrv :: ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c)
|
||||
newRcvConnSrv c userId connId enableNtfs cMode =
|
||||
fmap fst .:: newRcvConnSrv_ c userId connId enableNtfs cMode Nothing
|
||||
{-# INLINE newRcvConnSrv #-}
|
||||
|
||||
newRcvConnSrv_ :: forall c. ConnectionModeI c => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe ConnInfo -> Maybe CRClientData -> CR.InitialKeys -> SubscriptionMode -> SMPServerWithAuth -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c))
|
||||
newRcvConnSrv_ c userId connId enableNtfs cMode userData_ clientData pqInitKeys subMode srvWithAuth@(ProtoServerWithAuth srv _) = do
|
||||
case (cMode, pqInitKeys) of
|
||||
(SCMContact, CR.IKUsePQ) -> throwE $ CMD PROHIBITED "newRcvConnSrv"
|
||||
_ -> pure ()
|
||||
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
let sndSecure = case cMode of SCMInvitation -> True; SCMContact -> False
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srvWithAuth smpClientVRange subMode sndSecure `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
|
||||
case cMode of
|
||||
SCMContact -> pure $ CRContactUri crData
|
||||
SCMInvitation -> do
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
case userData_ of
|
||||
Just d -> do
|
||||
(nonce, qUri, cReq, qd) <- prepareLinkData d $ fst e2eKeys
|
||||
(rq, qUri') <- createRcvQueue (Just nonce) qd e2eKeys
|
||||
connReqWithShortLink qUri cReq qUri' (shortLink rq)
|
||||
Nothing -> do
|
||||
let qd = case cMode of SCMContact -> CQRContact Nothing; SCMInvitation -> CQRMessaging Nothing
|
||||
(_, qUri) <- createRcvQueue Nothing qd e2eKeys
|
||||
(,Nothing) <$> createConnReq qUri
|
||||
where
|
||||
createRcvQueue :: Maybe C.CbNonce -> ClntQueueReqData -> C.KeyPairX25519 -> AM (RcvQueue, SMPQueueUri)
|
||||
createRcvQueue nonce_ qd e2eKeys = do
|
||||
AgentConfig {smpClientVRange = vr} <- asks config
|
||||
let ntfCreds_ = Nothing -- TODO [short links]
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue_ c userId connId srvWithAuth vr qd subMode ntfCreds_ nonce_ e2eKeys `catchAgentError` \e -> liftIO (print e) >> throwE e
|
||||
atomically $ incSMPServerStat c userId srv connCreated
|
||||
rq' <- withStore c $ \db -> updateNewConnRcv db connId rq
|
||||
lift . when (subMode == SMSubscribe) $ addNewQueueSubscription c rq' tSess sessId
|
||||
when enableNtfs $ do
|
||||
ns <- asks ntfSupervisor
|
||||
atomically $ sendNtfSubCommand ns (NSCCreate, [connId])
|
||||
pure (rq', qUri)
|
||||
createConnReq :: SMPQueueUri -> AM (ConnectionRequestUri c)
|
||||
createConnReq qUri = do
|
||||
AgentConfig {smpAgentVRange, e2eEncryptVRange} <- asks config
|
||||
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
|
||||
case cMode of
|
||||
SCMContact -> pure $ CRContactUri crData
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
prepareLinkData :: ConnInfo -> C.PublicKeyX25519 -> AM (C.CbNonce, SMPQueueUri, ConnectionRequestUri c, ClntQueueReqData)
|
||||
prepareLinkData userData e2eDhKey = do
|
||||
g <- asks random
|
||||
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
nonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g
|
||||
sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g
|
||||
AgentConfig {smpClientVRange = vr, smpAgentVRange = agentVRange} <- asks config
|
||||
let sndId = SMP.EntityId $ C.sha3_256 corrId
|
||||
sndSecure = case cMode of SCMContact -> False; SCMInvitation -> True
|
||||
qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey sndSecure
|
||||
connReq <- createConnReq qUri
|
||||
let (linkKey, linkData) = SL.encodeSignLinkData sigKeys agentVRange connReq userData
|
||||
qd <- case cMode of
|
||||
SCMContact -> do
|
||||
let (linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
srvData <- liftIO $ SL.encryptLinkData g k linkData
|
||||
pure $ CQRContact $ Just CQRData {linkKey, privSigKey, srvReq = (linkId, (sndId, srvData))}
|
||||
SCMInvitation -> do
|
||||
let k = SL.invShortLinkKdf linkKey
|
||||
srvData <- liftIO $ SL.encryptLinkData g k linkData
|
||||
pure $ CQRMessaging $ Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)}
|
||||
pure (nonce, qUri, connReq, qd)
|
||||
connReqWithShortLink :: SMPQueueUri -> ConnectionRequestUri c -> SMPQueueUri -> Maybe ShortLinkCreds -> AM (ConnectionRequestUri c, Maybe (ConnShortLink c))
|
||||
connReqWithShortLink qUri cReq qUri' shortLink = case shortLink of
|
||||
Just ShortLinkCreds {shortLinkId, shortLinkKey}
|
||||
| qUri == qUri' ->
|
||||
let link = case cReq of
|
||||
CRContactUri _ -> CSLContact srv CCTContact shortLinkKey
|
||||
CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey
|
||||
in pure (cReq, Just link)
|
||||
| otherwise -> throwE $ INTERNAL "different rcv queue address"
|
||||
Nothing ->
|
||||
let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData)
|
||||
cReq' = case cReq of
|
||||
CRContactUri crData -> CRContactUri (updated crData)
|
||||
CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams
|
||||
in pure (cReq', Nothing)
|
||||
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of
|
||||
@@ -842,6 +952,7 @@ newConnToAccept c connId enableNtfs invId pqSup = do
|
||||
newConnToJoin c userId connId enableNtfs connReq pqSup
|
||||
_ -> throwE $ CMD PROHIBITED "newConnToAccept"
|
||||
|
||||
-- TODO [short link] joining queue that was already secured with LKEY
|
||||
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured
|
||||
joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
|
||||
srv <- getNextSMPServer c userId [qServer cReqQueue]
|
||||
@@ -958,8 +1069,8 @@ joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode
|
||||
|
||||
createReplyQueue :: AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> AM SMPQueueInfo
|
||||
createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do
|
||||
let sndSecure = smpClientVersion >= sndAuthKeySMPClientVersion
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode sndSecure
|
||||
-- TODO [short links] ntf credentials
|
||||
(rq, qUri, tSess, sessId) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) SCMInvitation subMode Nothing
|
||||
atomically $ incSMPServerStat c userId (qServer rq) connCreated
|
||||
let qInfo = toVersionT qUri smpClientVersion
|
||||
rq' <- withStore c $ \db -> upgradeSndConnToDuplex db connId rq
|
||||
@@ -1727,7 +1838,8 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s
|
||||
-- try to get the server that is different from all queues, or at least from the primary rcv queue
|
||||
srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
|
||||
srv' <- if srv == server then getNextSMPServer c userId [server] else pure srvAuth
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe False
|
||||
-- TODO [short links] send correct NTF credentials here
|
||||
(q, qUri, tSess, sessId) <- newRcvQueue c userId connId srv' clientVRange SCMInvitation SMSubscribe Nothing
|
||||
let rq' = (q :: NewRcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
|
||||
rq'' <- withStore c $ \db -> addConnRcvQueue db connId rq'
|
||||
lift $ addNewQueueSubscription c rq'' tSess sessId
|
||||
|
||||
@@ -26,6 +26,8 @@ module Simplex.Messaging.Agent.Client
|
||||
( AgentClient (..),
|
||||
ProtocolTestFailure (..),
|
||||
ProtocolTestStep (..),
|
||||
ClntQueueReqData (..),
|
||||
CQRData (..),
|
||||
newAgentClient,
|
||||
withConnLock,
|
||||
withConnLocks,
|
||||
@@ -43,6 +45,7 @@ module Simplex.Messaging.Agent.Client
|
||||
runNTFServerTest,
|
||||
getXFTPWorkPath,
|
||||
newRcvQueue,
|
||||
newRcvQueue_,
|
||||
subscribeQueues,
|
||||
getQueueMessage,
|
||||
decryptSMPMessage,
|
||||
@@ -57,6 +60,10 @@ module Simplex.Messaging.Agent.Client
|
||||
serverHostError,
|
||||
secureQueue,
|
||||
secureSndQueue,
|
||||
addQueueLink,
|
||||
deleteQueueLink,
|
||||
secureGetQueueLink,
|
||||
getQueueLink,
|
||||
enableQueueNotifications,
|
||||
EnableQueueNtfReq (..),
|
||||
enableQueuesNtfs,
|
||||
@@ -256,22 +263,25 @@ import Simplex.Messaging.Protocol
|
||||
RcvNtfPublicDhKey,
|
||||
SMPMsgMeta (..),
|
||||
SProtocolType (..),
|
||||
SenderCanSecure,
|
||||
SndPublicAuthKey,
|
||||
SubscriptionMode (..),
|
||||
QueueReqData (..),
|
||||
QueueLinkData,
|
||||
NewNtfCreds,
|
||||
UserProtocol,
|
||||
VersionRangeSMPC,
|
||||
VersionSMPC,
|
||||
XFTPServer,
|
||||
XFTPServerWithAuth,
|
||||
pattern NoEntity,
|
||||
senderCanSecure,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId), TransportError (..))
|
||||
import Simplex.Messaging.Transport (SMPVersion, SessionId, THandleParams (sessionId, thVersion), TransportError (..), TransportPeer (..), sndAuthKeySMPVersion, shortLinksSMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
@@ -1076,9 +1086,24 @@ sendOrProxySMPCommand ::
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError ())) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO ()) ->
|
||||
AM (Maybe SMPServer)
|
||||
sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr senderId sendCmdViaProxy sendCmdDirectly = do
|
||||
sendOrProxySMPCommand c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly =
|
||||
fst <$> sendOrProxySMPCommand_ c userId destSrv connId cmdStr entId sendCmdViaProxy sendCmdDirectly
|
||||
{-# INLINE sendOrProxySMPCommand #-}
|
||||
|
||||
sendOrProxySMPCommand_ ::
|
||||
forall a.
|
||||
AgentClient ->
|
||||
UserId ->
|
||||
SMPServer ->
|
||||
ConnId -> -- session entity ID, for short links LinkId is used
|
||||
ByteString ->
|
||||
SMP.EntityId -> -- sender or link ID
|
||||
(SMPClient -> ProxiedRelay -> ExceptT SMPClientError IO (Either ProxyClientError a)) ->
|
||||
(SMPClient -> ExceptT SMPClientError IO a) ->
|
||||
AM (Maybe SMPServer, a)
|
||||
sendOrProxySMPCommand_ c userId destSrv@ProtocolServer {host = destHosts} connId cmdStr entId sendCmdViaProxy sendCmdDirectly = do
|
||||
tSess <- mkTransportSession c userId destSrv connId
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) (sendDirectly tSess $> Nothing)
|
||||
ifM shouldUseProxy (sendViaProxy Nothing tSess) ((Nothing,) <$> sendDirectly tSess)
|
||||
where
|
||||
shouldUseProxy = do
|
||||
cfg <- getNetworkConfig c
|
||||
@@ -1096,13 +1121,13 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
SPFAllowProtected -> ipAddressProtected cfg destSrv
|
||||
SPFProhibit -> False
|
||||
unknownServer = liftIO $ maybe True (\srvs -> all (`S.notMember` knownHosts srvs) destHosts) <$> TM.lookupIO userId (smpServers c)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer)
|
||||
sendViaProxy :: Maybe SMPServerWithAuth -> SMPTransportSession -> AM (Maybe SMPServer, a)
|
||||
sendViaProxy proxySrv_ destSess@(_, _, connId_) = do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess senderId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r <- tryAgentError . withProxySession c proxySrv_ destSess entId ("PFWD " <> cmdStr) $ \(SMPConnectedClient smp _, proxySess@ProxiedRelay {prBasicAuth}) -> do
|
||||
r' <- liftClient SMP (clientServer smp) $ sendCmdViaProxy smp proxySess
|
||||
let proxySrv = protocolClientServer' smp
|
||||
case r' of
|
||||
Right () -> pure $ Just proxySrv
|
||||
Right r -> pure (Just proxySrv, r)
|
||||
Left proxyErr -> do
|
||||
case proxyErr of
|
||||
ProxyProtocolError (SMP.PROXY SMP.NO_SESSION) -> do
|
||||
@@ -1136,18 +1161,17 @@ sendOrProxySMPCommand c userId destSrv@ProtocolServer {host = destHosts} connId
|
||||
sameClient smp' = sessionId (thParams smp) == sessionId (thParams smp')
|
||||
sameProxiedRelay proxySess' = prSessionId proxySess == prSessionId proxySess'
|
||||
case r of
|
||||
Right r' -> do
|
||||
Right r'@(srv_, _) -> do
|
||||
atomically $ incSMPServerStat c userId destSrv sentViaProxy
|
||||
forM_ r' $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
|
||||
forM_ srv_ $ \proxySrv -> atomically $ incSMPServerStat c userId proxySrv sentProxied
|
||||
pure r'
|
||||
Left e
|
||||
| serverHostError e -> ifM directAllowed (sendDirectly destSess $> Nothing) (throwE e)
|
||||
| serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e)
|
||||
| otherwise -> throwE e
|
||||
sendDirectly tSess =
|
||||
withLogClient_ c tSess (unEntityId senderId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
r <- tryAgentError $ liftClient SMP (clientServer smp) $ sendCmdDirectly smp
|
||||
case r of
|
||||
Right () -> atomically $ incSMPServerStat c userId destSrv sentDirect
|
||||
withLogClient_ c tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do
|
||||
tryAgentError (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case
|
||||
Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect)
|
||||
Left e -> throwE e
|
||||
|
||||
ipAddressProtected :: NetworkConfig -> ProtocolServer p -> Bool
|
||||
@@ -1222,11 +1246,11 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do
|
||||
(sKey, spKey) <- atomically $ C.generateAuthKeyPair sa g
|
||||
(dhKey, _) <- atomically $ C.generateKeyPair g
|
||||
r <- runExceptT $ do
|
||||
SMP.QIK {rcvId, sndId, sndSecure} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe True
|
||||
SMP.QIK {rcvId, sndId, queueMode} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp Nothing rKeys dhKey auth SMSubscribe (QRMessaging Nothing) Nothing
|
||||
liftError (testErr TSSecureQueue) $
|
||||
if sndSecure
|
||||
then secureSndSMPQueue smp spKey sndId sKey
|
||||
else secureSMPQueue smp rpKey rcvId sKey
|
||||
case queueMode of
|
||||
Just QMMessaging -> secureSndSMPQueue smp spKey sndId sKey
|
||||
_ -> secureSMPQueue smp rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId
|
||||
ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
@@ -1333,19 +1357,42 @@ getSessionMode :: MonadIO m => AgentClient -> m TransportSessionMode
|
||||
getSessionMode = fmap sessionMode . getNetworkConfig
|
||||
{-# INLINE getSessionMode #-}
|
||||
|
||||
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SubscriptionMode -> SenderCanSecure -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode senderCanSecure = do
|
||||
-- TODO [short links] add ntf credentials to RcvQueue
|
||||
newRcvQueue :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> SConnectionMode c -> SubscriptionMode -> Maybe NewNtfCreds -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue c userId connId srv vRange cMode subMode ntfCreds = do
|
||||
let qrd = case cMode of SCMInvitation -> CQRMessaging Nothing; SCMContact -> CQRContact Nothing
|
||||
e2eKeys <- atomically . C.generateKeyPair =<< asks random
|
||||
newRcvQueue_ c userId connId srv vRange qrd subMode ntfCreds Nothing e2eKeys
|
||||
|
||||
data ClntQueueReqData
|
||||
= CQRMessaging (Maybe (CQRData (SMP.SenderId, QueueLinkData)))
|
||||
| CQRContact (Maybe (CQRData (SMP.LinkId, (SMP.SenderId, QueueLinkData))))
|
||||
|
||||
data CQRData r = CQRData
|
||||
{ linkKey :: LinkKey,
|
||||
privSigKey :: C.PrivateKeyEd25519,
|
||||
srvReq :: r
|
||||
}
|
||||
|
||||
queueReqData :: ClntQueueReqData -> QueueReqData
|
||||
queueReqData = \case
|
||||
CQRMessaging d -> QRMessaging $ srvReq <$> d
|
||||
CQRContact d -> QRContact $ srvReq <$> d
|
||||
|
||||
newRcvQueue_ :: AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRangeSMPC -> ClntQueueReqData -> SubscriptionMode -> Maybe NewNtfCreds -> Maybe C.CbNonce -> C.KeyPairX25519 -> AM (NewRcvQueue, SMPQueueUri, SMPTransportSession, SessionId)
|
||||
newRcvQueue_ c userId connId (ProtoServerWithAuth srv auth) vRange cqrd subMode ntfCreds nonce_ (e2eDhKey, e2ePrivKey) = do
|
||||
C.AuthAlg a <- asks (rcvAuthAlg . config)
|
||||
g <- asks random
|
||||
rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g
|
||||
(dhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
(e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g
|
||||
logServer "-->" c srv NoEntity "NEW"
|
||||
tSess <- mkTransportSession c userId srv connId
|
||||
(sessId, QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}) <-
|
||||
-- TODO [short links] serverNtfCreds
|
||||
r@(thParams', QIK {rcvId, sndId, rcvPublicDhKey, queueMode, serverNtfCreds}) <-
|
||||
withClient c tSess $ \(SMPConnectedClient smp _) ->
|
||||
(sessionId $ thParams smp,) <$> createSMPQueue smp rKeys dhKey auth subMode senderCanSecure
|
||||
(thParams smp,) <$> createSMPQueue smp nonce_ rKeys dhKey auth subMode (queueReqData cqrd) ntfCreds
|
||||
liftIO . logServer "<--" c srv NoEntity $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
shortLink <- mkShortLinkCreds r
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ userId,
|
||||
@@ -1358,17 +1405,47 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode sender
|
||||
e2eDhSecret = Nothing,
|
||||
sndId,
|
||||
sndSecure,
|
||||
shortLink,
|
||||
status = New,
|
||||
dbQueueId = DBNewQueue,
|
||||
primary = True,
|
||||
dbReplaceQueueId = Nothing,
|
||||
rcvSwchStatus = Nothing,
|
||||
smpClientVersion = maxVersion vRange,
|
||||
clientNtfCreds = Nothing,
|
||||
clientNtfCreds = Nothing, -- TODO [short links]
|
||||
deleteErrors = 0
|
||||
}
|
||||
qUri = SMPQueueUri vRange $ SMPQueueAddress srv sndId e2eDhKey sndSecure
|
||||
pure (rq, qUri, tSess, sessId)
|
||||
-- TODO [short links] maybe switch to queue mode?
|
||||
sndSecure = senderCanSecure queueMode
|
||||
pure (rq, qUri, tSess, sessionId thParams')
|
||||
where
|
||||
mkShortLinkCreds :: (THandleParams SMPVersion 'TClient, QueueIdsKeys) -> AM (Maybe ShortLinkCreds)
|
||||
mkShortLinkCreds (thParams', QIK {sndId, queueMode, linkId}) = case (cqrd, queueMode) of
|
||||
(CQRMessaging ld, Just QMMessaging) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (sndId', d)} ->
|
||||
if sndId == sndId'
|
||||
then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d)
|
||||
else newErr "different sender ID"
|
||||
(CQRContact ld, Just QMContact) ->
|
||||
withLinkData ld $ \lnkId CQRData {linkKey, privSigKey, srvReq = (lnkId', (sndId', d))} ->
|
||||
if sndId == sndId' && lnkId == lnkId'
|
||||
then pure $ Just $ ShortLinkCreds lnkId linkKey privSigKey (fst d)
|
||||
else newErr "different sender or link IDs"
|
||||
(_, Nothing) -> case linkId of
|
||||
Nothing | v < sndAuthKeySMPVersion -> pure Nothing
|
||||
_ -> newErr "unexpected link ID"
|
||||
_ -> newErr "unexpected queue mode"
|
||||
where
|
||||
v = thVersion thParams'
|
||||
withLinkData :: Maybe d -> (SMP.LinkId -> d -> AM (Maybe ShortLinkCreds)) -> AM (Maybe ShortLinkCreds)
|
||||
withLinkData ld_ mkLink = case (ld_, linkId) of
|
||||
(Just ld, Just lnkId) -> mkLink lnkId ld
|
||||
(Just _, Nothing) | v < shortLinksSMPVersion -> pure Nothing
|
||||
(Nothing, Nothing) -> pure Nothing
|
||||
_ -> newErr "unexpected or absent link ID"
|
||||
newErr :: String -> AM (Maybe ShortLinkCreds)
|
||||
newErr = throwE . BROKER (B.unpack $ strEncode srv) . UNEXPECTED . ("Create queue: " <>)
|
||||
|
||||
processSubResult :: AgentClient -> SessionId -> RcvQueue -> Either SMPClientError () -> STM ()
|
||||
processSubResult c sessId rq@RcvQueue {userId, server, connId} = \case
|
||||
@@ -1611,6 +1688,28 @@ secureSndQueue c SndQueue {userId, connId, server, sndId, sndPrivateKey, sndPubl
|
||||
secureViaProxy smp proxySess = proxySecureSndSMPQueue smp proxySess sndPrivateKey sndId sndPublicKey
|
||||
secureDirectly smp = secureSndSMPQueue smp sndPrivateKey sndId sndPublicKey
|
||||
|
||||
addQueueLink :: AgentClient -> RcvQueue -> SMP.LinkId -> QueueLinkData -> AM ()
|
||||
addQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} lnkId d =
|
||||
withSMPClient c rq "LSET" $ \smp -> addSMPQueueLink smp rcvPrivateKey rcvId lnkId d
|
||||
|
||||
deleteQueueLink :: AgentClient -> RcvQueue -> AM ()
|
||||
deleteQueueLink c rq@RcvQueue {rcvId, rcvPrivateKey} =
|
||||
withSMPClient c rq "LDEL" $ \smp -> deleteSMPQueueLink smp rcvPrivateKey rcvId
|
||||
|
||||
secureGetQueueLink :: AgentClient -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData)
|
||||
secureGetQueueLink c userId InvShortLink {server, linkId, sndPrivateKey, sndPublicKey} =
|
||||
snd <$> sendOrProxySMPCommand_ c userId server (unEntityId linkId) "LKEY <key>" linkId secureGetViaProxy secureGetDirectly
|
||||
where
|
||||
secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp proxySess sndPrivateKey linkId sndPublicKey
|
||||
secureGetDirectly smp = secureGetSMPQueueLink smp sndPrivateKey linkId sndPublicKey
|
||||
|
||||
getQueueLink :: AgentClient -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData)
|
||||
getQueueLink c userId server lnkId =
|
||||
snd <$> sendOrProxySMPCommand_ c userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly
|
||||
where
|
||||
getViaProxy smp proxySess = proxyGetSMPQueueLink smp proxySess lnkId
|
||||
getDirectly smp = getSMPQueueLink smp lnkId
|
||||
|
||||
enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
|
||||
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
|
||||
withSMPClient c rq "NKEY <nkey>" $ \smp ->
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@@ -108,6 +110,11 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnReqUriData (..),
|
||||
CRClientData,
|
||||
ServiceScheme,
|
||||
FixedLinkData (..),
|
||||
UserLinkData (..),
|
||||
ConnShortLink (..),
|
||||
ContactConnType (..),
|
||||
LinkKey (..),
|
||||
sameConnReqContact,
|
||||
simplexChat,
|
||||
connReqUriP',
|
||||
@@ -151,8 +158,10 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Base64.URL as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isDigit)
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Kind (Type)
|
||||
@@ -1042,6 +1051,11 @@ instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
|
||||
<> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
|
||||
strP = connReqUriP' (Just SSSimplex)
|
||||
|
||||
-- TODO [short links] do not use StrEncoding instance
|
||||
instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where
|
||||
smpEncode = smpEncode . Large . strEncode
|
||||
smpP = strDecode . unLarge <$?> smpP
|
||||
|
||||
connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m)
|
||||
connReqUriP' overrideScheme = do
|
||||
ACR m cr <- connReqUriP overrideScheme
|
||||
@@ -1188,7 +1202,7 @@ data SMPQueueAddress = SMPQueueAddress
|
||||
{ smpServer :: SMPServer,
|
||||
senderId :: SMP.SenderId,
|
||||
dhPublicKey :: C.PublicKeyX25519,
|
||||
sndSecure :: Bool
|
||||
sndSecure :: Bool -- TODO [short links] replace with queueMode?
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -1271,6 +1285,65 @@ instance Eq AConnectionRequestUri where
|
||||
|
||||
deriving instance Show AConnectionRequestUri
|
||||
|
||||
data ConnShortLink (m :: ConnectionMode) where
|
||||
CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation
|
||||
CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact
|
||||
|
||||
deriving instance Show (ConnShortLink m)
|
||||
|
||||
newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data)
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (FromField, StrEncoding)
|
||||
|
||||
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
|
||||
|
||||
data ContactConnType = CCTContact | CCTGroup deriving (Show)
|
||||
|
||||
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
|
||||
|
||||
-- TODO [short link] parser, parsing tests
|
||||
data AConnectionLink = ACLFull AConnectionRequestUri | ACLShort AConnShortLink
|
||||
|
||||
instance ConnectionModeI m => StrEncoding (ConnShortLink m) where
|
||||
strEncode = \case
|
||||
CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i"
|
||||
CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g"
|
||||
where
|
||||
encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType =
|
||||
"https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> B64.encodeUnpadded kh <> "@" <> hosts <> B64.encodeUnpadded linkUri
|
||||
where
|
||||
port' = if null port then "" else B.pack (':' : port)
|
||||
hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/"
|
||||
strP = do
|
||||
ACSL m l <- strP
|
||||
case testEquality m $ sConnectionMode @m of
|
||||
Just Refl -> pure l
|
||||
_ -> fail "bad short link mode"
|
||||
|
||||
instance StrEncoding AConnShortLink where
|
||||
strEncode (ACSL _ l) = strEncode l
|
||||
strP = do
|
||||
h <- "https://" *> strP
|
||||
port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure ""
|
||||
linkType <- A.char '/' *> A.anyChar
|
||||
keyHash <- optional (A.char '/') *> A.char '#' *> strP <* A.char '@'
|
||||
TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ [])
|
||||
linkUri <- strP
|
||||
let srv = SMPServer (h :| hs) port keyHash
|
||||
case linkType of
|
||||
'i'
|
||||
| B.length linkUri == 56 ->
|
||||
let (lnkId, k) = B.splitAt 24 linkUri
|
||||
in pure $ ACSL SCMInvitation $ CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k)
|
||||
| otherwise -> fail "bad ConnShortLink: incorrect linkID and key length"
|
||||
'c' -> contactP srv CCTContact linkUri
|
||||
'g' -> contactP srv CCTGroup linkUri
|
||||
_ -> fail "bad ConnShortLink: unknown link type"
|
||||
where
|
||||
contactP srv ct k
|
||||
| B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k)
|
||||
| otherwise = fail "bad ConnShortLink: incorrect key length"
|
||||
|
||||
sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
|
||||
sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
|
||||
L.length qs == L.length qs' && all same (L.zip qs qs')
|
||||
@@ -1287,6 +1360,31 @@ data ConnReqUriData = ConnReqUriData
|
||||
|
||||
type CRClientData = Text
|
||||
|
||||
data FixedLinkData c = FixedLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
sigKey :: C.PublicKeyEd25519,
|
||||
connReq :: ConnectionRequestUri c
|
||||
}
|
||||
|
||||
data UserLinkData = UserLinkData
|
||||
{ agentVRange :: VersionRangeSMPA,
|
||||
userData :: ConnInfo
|
||||
}
|
||||
|
||||
instance ConnectionModeI c => Encoding (FixedLinkData c) where
|
||||
smpEncode FixedLinkData {agentVRange, sigKey, connReq} =
|
||||
smpEncode (agentVRange, sigKey, connReq)
|
||||
smpP = do
|
||||
(agentVRange, sigKey, connReq) <- smpP
|
||||
pure FixedLinkData {agentVRange, sigKey, connReq}
|
||||
|
||||
instance Encoding UserLinkData where
|
||||
smpEncode UserLinkData {agentVRange, userData} =
|
||||
smpEncode (agentVRange, Large userData)
|
||||
smpP = do
|
||||
(agentVRange, Large userData) <- smpP
|
||||
pure UserLinkData {agentVRange, userData}
|
||||
|
||||
-- | SMP queue status.
|
||||
data QueueStatus
|
||||
= -- | queue is created
|
||||
@@ -1419,6 +1517,8 @@ data SMPAgentError
|
||||
A_PROHIBITED {prohibitedErr :: String}
|
||||
| -- | incompatible version of SMP client, agent or encryption protocols
|
||||
A_VERSION
|
||||
| -- | failed signature, hash or senderId verification of retrieved link data
|
||||
A_LINK {linkErr :: String}
|
||||
| -- | cannot decrypt message
|
||||
A_CRYPTO {cryptoErr :: AgentCryptoError}
|
||||
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown
|
||||
|
||||
@@ -93,6 +93,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
|
||||
sndId :: SMP.SenderId,
|
||||
-- | sender can secure the queue
|
||||
sndSecure :: SenderCanSecure,
|
||||
-- | short link ID and credentials
|
||||
shortLink :: Maybe ShortLinkCreds,
|
||||
-- | queue status
|
||||
status :: QueueStatus,
|
||||
-- | database queue ID (within connection)
|
||||
@@ -110,6 +112,14 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ShortLinkCreds = ShortLinkCreds
|
||||
{ shortLinkId :: SMP.LinkId,
|
||||
shortLinkKey :: LinkKey,
|
||||
linkPrivSigKey :: C.PrivateKeyEd25519,
|
||||
linkEncFixedData :: SMP.EncFixedDataBytes
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
rcvQueueInfo :: RcvQueue -> RcvQueueInfo
|
||||
rcvQueueInfo rq@RcvQueue {server, rcvSwchStatus} =
|
||||
RcvQueueInfo {rcvServer = server, rcvSwitchStatus = rcvSwchStatus, canAbortSwitch = canAbortRcvSwitch rq}
|
||||
@@ -137,6 +147,18 @@ data ClientNtfCreds = ClientNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- This record is stored in inv_short_links table.
|
||||
-- It is needed only for 1-time invitation links because of "secure-on-read" property of link data,
|
||||
-- that prevents undetected access to link data from link observers.
|
||||
data InvShortLink = InvShortLink
|
||||
{ server :: SMPServer,
|
||||
linkId :: SMP.LinkId,
|
||||
linkKey :: LinkKey,
|
||||
sndPrivateKey :: SndPrivateAuthKey, -- stored to allow retries
|
||||
sndPublicKey :: SndPublicAuthKey
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type SndQueue = StoredSndQueue 'QSStored
|
||||
|
||||
type NewSndQueue = StoredSndQueue 'QSNew
|
||||
|
||||
@@ -58,6 +58,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
getRcvQueueById,
|
||||
getSndQueueById,
|
||||
deleteConn,
|
||||
deleteConnRecord,
|
||||
upgradeRcvConnToDuplex,
|
||||
upgradeSndConnToDuplex,
|
||||
addConnRcvQueue,
|
||||
@@ -88,6 +89,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
acceptInvitation,
|
||||
unacceptInvitation,
|
||||
deleteInvitation,
|
||||
getInvShortLink,
|
||||
createInvShortLink,
|
||||
-- Messages
|
||||
updateRcvIds,
|
||||
createRcvMsg,
|
||||
@@ -410,6 +413,9 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup
|
||||
|]
|
||||
(userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True)
|
||||
|
||||
deleteConnRecord :: DB.Connection -> ConnId -> IO ()
|
||||
deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId)
|
||||
|
||||
checkConfirmedSndQueueExists_ :: DB.Connection -> NewSndQueue -> IO Bool
|
||||
checkConfirmedSndQueueExists_ db SndQueue {server, sndId} = do
|
||||
fromMaybe False
|
||||
@@ -442,7 +448,7 @@ deleteConn db waitDeliveryTimeout_ connId = case waitDeliveryTimeout_ of
|
||||
(pure Nothing)
|
||||
)
|
||||
where
|
||||
delete = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) $> Just connId
|
||||
delete = deleteConnRecord db connId $> Just connId
|
||||
checkNoPendingDeliveries_ = do
|
||||
r :: (Maybe Int64) <-
|
||||
maybeFirstRow fromOnly $
|
||||
@@ -756,6 +762,40 @@ deleteInvitation db contactConnId invId =
|
||||
Right <$> DB.execute db "DELETE FROM conn_invitations WHERE contact_conn_id = ? AND invitation_id = ?" (contactConnId, Binary invId)
|
||||
_ -> pure $ Left SEConnNotFound
|
||||
|
||||
getInvShortLink :: DB.Connection -> SMPServer -> LinkId -> IO (Maybe InvShortLink)
|
||||
getInvShortLink db server linkId =
|
||||
maybeFirstRow toInvShortLink $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT link_key, snd_private_key
|
||||
FROM inv_short_links
|
||||
WHERE host = ? AND port = ? AND link_id = ?
|
||||
|]
|
||||
(host server, port server, linkId)
|
||||
where
|
||||
toInvShortLink :: (LinkKey, C.APrivateAuthKey) -> InvShortLink
|
||||
toInvShortLink (linkKey, sndPrivateKey@(C.APrivateAuthKey a pk)) =
|
||||
let sndPublicKey = C.APublicAuthKey a $ C.publicKey pk
|
||||
in InvShortLink {server, linkId, linkKey, sndPrivateKey, sndPublicKey}
|
||||
|
||||
createInvShortLink :: DB.Connection -> InvShortLink -> IO ()
|
||||
createInvShortLink db InvShortLink {server, linkId, linkKey, sndPrivateKey} = do
|
||||
serverKeyHash_ <- createServer_ db server
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO inv_short_links
|
||||
(host, port, server_key_hash, link_id, link_key, snd_private_key)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
ON CONFLICT (host, port, link_id)
|
||||
DO UPDATE SET
|
||||
server_key_hash = EXCLUDED.server_key_hash,
|
||||
link_key = EXCLUDED.link_key,
|
||||
snd_private_key = EXCLUDED.snd_private_key
|
||||
|]
|
||||
(host server, port server, serverKeyHash_, linkId, linkKey, sndPrivateKey)
|
||||
|
||||
updateRcvIds :: DB.Connection -> ConnId -> IO (InternalId, InternalRcvId, PrevExternalSndId, PrevRcvMsgHash)
|
||||
updateRcvIds db connId = do
|
||||
(lastInternalId, lastInternalRcvId, lastExternalSndId, lastRcvHash) <- retrieveLastIdsAndHashRcv_ db connId
|
||||
@@ -1884,9 +1924,15 @@ insertRcvQueue_ db connId' rq@RcvQueue {..} serverKeyHash_ = do
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO rcv_queues
|
||||
(host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret,
|
||||
snd_id, snd_secure, status, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash,
|
||||
link_id, link_key, link_priv_sig_key, link_enc_fixed_data
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);
|
||||
|]
|
||||
((host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret) :. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_))
|
||||
( (host server, port server, rcvId, connId', rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret)
|
||||
:. (sndId, BI sndSecure, status, qId, BI primary, dbReplaceQueueId, smpClientVersion, serverKeyHash_)
|
||||
:. (shortLinkId <$> shortLink, shortLinkKey <$> shortLink, linkPrivSigKey <$> shortLink, linkEncFixedData <$> shortLink)
|
||||
)
|
||||
pure (rq :: NewRcvQueue) {connId = connId', dbQueueId = qId}
|
||||
|
||||
-- * createSndConn helpers
|
||||
@@ -2054,7 +2100,8 @@ rcvQueueQuery =
|
||||
SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
|
||||
q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.snd_secure, q.status,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors,
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret
|
||||
q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret,
|
||||
q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
@@ -2063,15 +2110,24 @@ rcvQueueQuery =
|
||||
toRcvQueue ::
|
||||
(UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, BoolInt)
|
||||
:. (QueueStatus, DBQueueId 'QSStored, BoolInt, Maybe Int64, Maybe RcvSwitchStatus, Maybe VersionSMPC, Int)
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) ->
|
||||
:. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret)
|
||||
:. (Maybe SMP.LinkId, Maybe LinkKey, Maybe C.PrivateKeyEd25519, Maybe EncDataBytes) ->
|
||||
RcvQueue
|
||||
toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure) :. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) =
|
||||
toRcvQueue
|
||||
( (userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, BI sndSecure)
|
||||
:. (status, dbQueueId, BI primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors)
|
||||
:. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)
|
||||
:. (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_)
|
||||
) =
|
||||
let server = SMPServer host port keyHash
|
||||
smpClientVersion = fromMaybe initialSMPClientVersion smpClientVersion_
|
||||
clientNtfCreds = case (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_) of
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just $ ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
(Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) -> Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret}
|
||||
_ -> Nothing
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
shortLink = case (shortLinkId_, shortLinkKey_, linkPrivSigKey_, linkEncFixedData_) of
|
||||
(Just shortLinkId, Just shortLinkKey, Just linkPrivSigKey, Just linkEncFixedData) -> Just ShortLinkCreds {shortLinkId, shortLinkKey, linkPrivSigKey, linkEncFixedData}
|
||||
_ -> Nothing
|
||||
in RcvQueue {userId, connId, server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, sndSecure, shortLink, status, dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion, clientNtfCreds, deleteErrors}
|
||||
|
||||
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById db connId dbRcvId =
|
||||
|
||||
@@ -6,12 +6,14 @@ import Data.List (sortOn)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20241210_initial
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
schemaMigrations =
|
||||
[ ("20241210_initial", m20241210_initial, Nothing),
|
||||
("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
|
||||
("20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20250322_short_links where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20250322_short_links :: Text
|
||||
m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BYTEA;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BYTEA;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BYTEA,
|
||||
link_id BYTEA NOT NULL,
|
||||
link_key BYTEA NOT NULL,
|
||||
snd_private_key BYTEA NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Text
|
||||
down_m20250322_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|]
|
||||
@@ -42,6 +42,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240930_ntf_tokens_to_d
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241007_rcv_queues_last_broker_ts
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20241224_ratchet_e2e_snd_params
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250203_msg_bodies
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -83,7 +84,8 @@ schemaMigrations =
|
||||
("m20240930_ntf_tokens_to_delete", m20240930_ntf_tokens_to_delete, Just down_m20240930_ntf_tokens_to_delete),
|
||||
("m20241007_rcv_queues_last_broker_ts", m20241007_rcv_queues_last_broker_ts, Just down_m20241007_rcv_queues_last_broker_ts),
|
||||
("m20241224_ratchet_e2e_snd_params", m20241224_ratchet_e2e_snd_params, Just down_m20241224_ratchet_e2e_snd_params),
|
||||
("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies)
|
||||
("m20250203_msg_bodies", m20250203_msg_bodies, Just down_m20250203_msg_bodies),
|
||||
("m20250322_short_links", m20250322_short_links, Just down_m20250322_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20250322_short_links where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20250322_short_links :: Query
|
||||
m20250322_short_links =
|
||||
[sql|
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_id BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_priv_sig_key BLOB;
|
||||
ALTER TABLE rcv_queues ADD COLUMN link_enc_fixed_data BLOB;
|
||||
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(host, port, link_id);
|
||||
|]
|
||||
|
||||
down_m20250322_short_links :: Query
|
||||
down_m20250322_short_links =
|
||||
[sql|
|
||||
DROP INDEX idx_rcv_queues_link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_id;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_priv_sig_key;
|
||||
ALTER TABLE rcv_queues DROP COLUMN link_enc_fixed_data;
|
||||
|
||||
DROP INDEX idx_inv_short_links_link_id;
|
||||
DROP TABLE inv_short_links;
|
||||
|]
|
||||
@@ -57,6 +57,10 @@ CREATE TABLE rcv_queues(
|
||||
deleted INTEGER NOT NULL DEFAULT 0,
|
||||
snd_secure INTEGER NOT NULL DEFAULT 0,
|
||||
last_broker_ts TEXT,
|
||||
link_id BLOB,
|
||||
link_key BLOB,
|
||||
link_priv_sig_key BLOB,
|
||||
link_enc_fixed_data BLOB,
|
||||
PRIMARY KEY(host, port, rcv_id),
|
||||
FOREIGN KEY(host, port) REFERENCES servers
|
||||
ON DELETE RESTRICT ON UPDATE CASCADE,
|
||||
@@ -422,6 +426,16 @@ CREATE TABLE snd_message_bodies(
|
||||
snd_message_body_id INTEGER PRIMARY KEY,
|
||||
agent_msg BLOB NOT NULL DEFAULT x''
|
||||
);
|
||||
CREATE TABLE inv_short_links(
|
||||
inv_short_link_id INTEGER PRIMARY KEY AUTOINCREMENT,
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
server_key_hash BLOB,
|
||||
link_id BLOB NOT NULL,
|
||||
link_key BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
FOREIGN KEY(host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_ntf ON rcv_queues(host, port, ntf_id);
|
||||
CREATE UNIQUE INDEX idx_rcv_queue_id ON rcv_queues(conn_id, rcv_queue_id);
|
||||
CREATE UNIQUE INDEX idx_snd_queue_id ON snd_queues(conn_id, snd_queue_id);
|
||||
@@ -551,3 +565,9 @@ CREATE INDEX idx_rcv_files_redirect_id on rcv_files(redirect_id);
|
||||
CREATE INDEX idx_snd_messages_snd_message_body_id ON snd_messages(
|
||||
snd_message_body_id
|
||||
);
|
||||
CREATE UNIQUE INDEX idx_rcv_queues_link_id ON rcv_queues(host, port, link_id);
|
||||
CREATE UNIQUE INDEX idx_inv_short_links_link_id ON inv_short_links(
|
||||
host,
|
||||
port,
|
||||
link_id
|
||||
);
|
||||
|
||||
@@ -49,6 +49,12 @@ module Simplex.Messaging.Client
|
||||
secureSMPQueue,
|
||||
secureSndSMPQueue,
|
||||
proxySecureSndSMPQueue,
|
||||
addSMPQueueLink,
|
||||
deleteSMPQueueLink,
|
||||
secureGetSMPQueueLink,
|
||||
proxySecureGetSMPQueueLink,
|
||||
getSMPQueueLink,
|
||||
proxyGetSMPQueueLink,
|
||||
enableSMPQueueNotifications,
|
||||
disableSMPQueueNotifications,
|
||||
enableSMPQueuesNtfs,
|
||||
@@ -706,14 +712,16 @@ smpProxyError = \case
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
|
||||
createSMPQueue ::
|
||||
SMPClient ->
|
||||
Maybe C.CbNonce -> -- used as correlation ID to allow deriving SenderId from it for short links
|
||||
C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair
|
||||
RcvPublicDhKey ->
|
||||
Maybe BasicAuth ->
|
||||
SubscriptionMode ->
|
||||
Bool ->
|
||||
QueueReqData ->
|
||||
Maybe NewNtfCreds ->
|
||||
ExceptT SMPClientError IO QueueIdsKeys
|
||||
createSMPQueue c (rKey, rpKey) dhKey auth subMode sndSecure =
|
||||
sendSMPCommand c (Just rpKey) NoEntity (NEW rKey dhKey auth subMode sndSecure) >>= \case
|
||||
createSMPQueue c nonce_ (rKey, rpKey) dhKey auth subMode qrd ntfCreds =
|
||||
sendProtocolCommand_ c nonce_ Nothing (Just rpKey) NoEntity (Cmd SRecipient $ NEW $ NewQueueReq rKey dhKey auth subMode (Just qrd) ntfCreds) >>= \case
|
||||
IDS qik -> pure qik
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
@@ -799,9 +807,47 @@ 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 = proxyOKSMPCommand c proxiedRelay (Just spKey) sId (SKEY senderKey)
|
||||
{-# INLINE proxySecureSndSMPQueue #-}
|
||||
|
||||
-- | Add or update date for queue link
|
||||
addSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> LinkId -> QueueLinkData -> ExceptT SMPClientError IO ()
|
||||
addSMPQueueLink c rpKey rId lnkId d = okSMPCommand (LSET lnkId d) c rpKey rId
|
||||
{-# INLINE addSMPQueueLink #-}
|
||||
|
||||
-- | Delete queue link
|
||||
deleteSMPQueueLink :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO ()
|
||||
deleteSMPQueueLink = okSMPCommand LDEL
|
||||
{-# INLINE deleteSMPQueueLink #-}
|
||||
|
||||
-- | Get 1-time inviation SMP queue link data and secure the queue via queue link ID.
|
||||
secureGetSMPQueueLink :: SMPClient -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
secureGetSMPQueueLink c spKey lnkId senderKey =
|
||||
sendSMPCommand c (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxySecureGetSMPQueueLink :: SMPClient -> ProxiedRelay -> SndPrivateAuthKey -> LinkId -> SndPublicAuthKey -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxySecureGetSMPQueueLink c proxiedRelay spKey lnkId senderKey =
|
||||
proxySMPCommand c proxiedRelay (Just spKey) lnkId (LKEY senderKey) >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Get contact address SMP queue link data.
|
||||
getSMPQueueLink :: SMPClient -> LinkId -> ExceptT SMPClientError IO (SenderId, QueueLinkData)
|
||||
getSMPQueueLink c lnkId =
|
||||
sendSMPCommand c Nothing lnkId LGET >>= \case
|
||||
LNK sId d -> pure (sId, d)
|
||||
r -> throwE $ unexpectedResponse r
|
||||
|
||||
proxyGetSMPQueueLink :: SMPClient -> ProxiedRelay -> LinkId -> ExceptT SMPClientError IO (Either ProxyClientError (SenderId, QueueLinkData))
|
||||
proxyGetSMPQueueLink c proxiedRelay lnkId =
|
||||
proxySMPCommand c proxiedRelay Nothing lnkId LGET >>= \case
|
||||
Right (LNK sId d) -> pure $ Right (sId, d)
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
-- | Enable notifications for the queue for push notifications server.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
|
||||
@@ -843,7 +889,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 = proxyOKSMPCommand c proxiedRelay spKey sId (SEND flags msg)
|
||||
|
||||
-- | Acknowledge message delivery (server deletes the message).
|
||||
--
|
||||
@@ -955,15 +1001,24 @@ 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
|
||||
proxyOKSMPCommand :: SMPClient -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> Command 'Sender -> ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
proxyOKSMPCommand c proxiedRelay spKey sId command =
|
||||
proxySMPCommand c proxiedRelay spKey sId command >>= \case
|
||||
Right OK -> pure $ Right ()
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
|
||||
proxySMPCommand ::
|
||||
forall p.
|
||||
PartyI p =>
|
||||
SMPClient ->
|
||||
-- proxy session from PKEY
|
||||
ProxiedRelay ->
|
||||
-- message to deliver
|
||||
Maybe SndPrivateAuthKey ->
|
||||
SenderId ->
|
||||
Command 'Sender ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError ())
|
||||
Command p ->
|
||||
ExceptT SMPClientError IO (Either ProxyClientError BrokerMsg)
|
||||
proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {clientCorrId = g, tcpTimeout}} (ProxiedRelay sessionId v _ serverKey) spKey sId command = do
|
||||
-- prepare params
|
||||
let serverThAuth = (\ta -> ta {serverPeerPubKey = serverKey}) <$> thAuth proxyThParams
|
||||
@@ -972,7 +1027,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c
|
||||
let cmdSecret = C.dh' serverKey cmdPrivKey
|
||||
nonce@(C.CbNonce corrId) <- liftIO . atomically $ C.randomCbNonce g
|
||||
-- encode
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd SSender command)
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth serverThParams (CorrId corrId, sId, Cmd (sParty @p) command)
|
||||
auth <- liftEitherWith PCETransportError $ authTransmission serverThAuth spKey nonce tForAuth
|
||||
b <- case batchTransmissions (batch serverThParams) (blockSize serverThParams) [Right (auth, tToSend)] of
|
||||
[] -> throwE $ PCETransportError TELargeMsg
|
||||
@@ -990,9 +1045,8 @@ 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' -> pure $ Right 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
|
||||
@@ -1101,6 +1155,8 @@ sendProtocolCommand c = sendProtocolCommand_ c Nothing Nothing
|
||||
-- This is to reflect the fact that we send subscriptions only as batches, and also because we do not track a separate timeout for the whole batch, so it is not obvious when should we expire it.
|
||||
-- We could expire a batch of deletes, for example, either when the first response expires or when the last one does.
|
||||
-- But a better solution is to process delayed delete responses.
|
||||
--
|
||||
-- Please note: if nonce is passed it is also used as a correlation ID
|
||||
sendProtocolCommand_ :: forall v err msg. Protocol v err msg => ProtocolClient v err msg -> Maybe C.CbNonce -> Maybe Int -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
|
||||
sendProtocolCommand_ c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} nonce_ tOut pKey entId cmd =
|
||||
ExceptT $ uncurry sendRecv =<< mkTransmission_ c nonce_ (pKey, entId, cmd)
|
||||
|
||||
@@ -142,6 +142,8 @@ module Simplex.Messaging.Crypto
|
||||
cbDecryptNoPad,
|
||||
sbDecrypt_,
|
||||
sbEncrypt_,
|
||||
sbEncryptNoPad,
|
||||
sbDecryptNoPad,
|
||||
cbNonce,
|
||||
randomCbNonce,
|
||||
reverseNonce,
|
||||
@@ -160,6 +162,7 @@ module Simplex.Messaging.Crypto
|
||||
SbKeyNonce,
|
||||
sbcInit,
|
||||
sbcHkdf,
|
||||
hkdf,
|
||||
|
||||
-- * pseudo-random bytes
|
||||
randomBytes,
|
||||
@@ -167,6 +170,7 @@ module Simplex.Messaging.Crypto
|
||||
-- * digests
|
||||
sha256Hash,
|
||||
sha512Hash,
|
||||
sha3_256,
|
||||
|
||||
-- * Message padding / un-padding
|
||||
canPad,
|
||||
@@ -207,7 +211,7 @@ import Crypto.Cipher.AES (AES256)
|
||||
import qualified Crypto.Cipher.Types as AES
|
||||
import qualified Crypto.Cipher.XSalsa as XSalsa
|
||||
import qualified Crypto.Error as CE
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize)
|
||||
import Crypto.Hash (Digest, SHA256 (..), SHA3_256, SHA512 (..), hash, hashDigestSize)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import qualified Crypto.MAC.Poly1305 as Poly1305
|
||||
import qualified Crypto.PubKey.Curve25519 as X25519
|
||||
@@ -887,6 +891,7 @@ x448_size = 448 `quot` 8
|
||||
validSignatureSize :: Int -> Bool
|
||||
validSignatureSize n =
|
||||
n == Ed25519.signatureSize || n == Ed448.signatureSize
|
||||
{-# INLINE validSignatureSize #-}
|
||||
|
||||
-- | AES key newtype.
|
||||
newtype Key = Key {unKey :: ByteString}
|
||||
@@ -961,10 +966,17 @@ instance FromField KeyHash where fromField = blobFieldDecoder $ parseAll strP
|
||||
-- | SHA256 digest.
|
||||
sha256Hash :: ByteString -> ByteString
|
||||
sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
|
||||
{-# INLINE sha256Hash #-}
|
||||
|
||||
-- | SHA512 digest.
|
||||
sha512Hash :: ByteString -> ByteString
|
||||
sha512Hash = BA.convert . (hash :: ByteString -> Digest SHA512)
|
||||
{-# INLINE sha512Hash #-}
|
||||
|
||||
-- | SHA3-256 digest.
|
||||
sha3_256 :: ByteString -> ByteString
|
||||
sha3_256 = BA.convert . (hash :: ByteString -> Digest SHA3_256)
|
||||
{-# INLINE sha3_256 #-}
|
||||
|
||||
-- | AEAD-GCM encryption with associated data.
|
||||
--
|
||||
@@ -981,6 +993,7 @@ encryptAEAD aesKey ivBytes paddedLen ad msg = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
encryptAESNoPad :: Key -> GCMIV -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAESNoPad key iv = encryptAEADNoPad key iv ""
|
||||
{-# INLINE encryptAESNoPad #-}
|
||||
|
||||
encryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> ExceptT CryptoError IO (AuthTag, ByteString)
|
||||
encryptAEADNoPad aesKey ivBytes ad msg = do
|
||||
@@ -1002,6 +1015,7 @@ decryptAEAD aesKey ivBytes ad msg (AuthTag authTag) = do
|
||||
-- This function requires 12 bytes IV, it does not transform IV.
|
||||
decryptAESNoPad :: Key -> GCMIV -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAESNoPad key iv = decryptAEADNoPad key iv ""
|
||||
{-# INLINE decryptAESNoPad #-}
|
||||
|
||||
decryptAEADNoPad :: Key -> GCMIV -> ByteString -> ByteString -> AuthTag -> ExceptT CryptoError IO ByteString
|
||||
decryptAEADNoPad aesKey iv ad msg (AuthTag tag) = do
|
||||
@@ -1054,6 +1068,7 @@ maxLenBS s
|
||||
|
||||
unsafeMaxLenBS :: forall i. KnownNat i => ByteString -> MaxLenBS i
|
||||
unsafeMaxLenBS = MLBS
|
||||
{-# INLINE unsafeMaxLenBS #-}
|
||||
|
||||
padMaxLenBS :: forall i. KnownNat i => MaxLenBS i -> MaxLenBS (i + 2)
|
||||
padMaxLenBS (MLBS msg) = MLBS $ encodeWord16 (fromIntegral len) <> msg <> B.replicate padLen '#'
|
||||
@@ -1066,6 +1081,7 @@ appendMaxLenBS (MLBS s1) (MLBS s2) = MLBS $ s1 <> s2
|
||||
|
||||
maxLength :: forall i. KnownNat i => Int
|
||||
maxLength = fromIntegral (natVal $ Proxy @i)
|
||||
{-# INLINE maxLength #-}
|
||||
|
||||
-- this function requires 16 bytes IV, it transforms IV in cryptonite_aes_gcm_init here:
|
||||
-- https://github.com/haskell-crypto/cryptonite/blob/master/cbits/cryptonite_aes.c
|
||||
@@ -1086,12 +1102,15 @@ initAEADGCM (Key aesKey) (GCMIV ivBytes) = cryptoFailable $ do
|
||||
-- | Random AES256 key.
|
||||
randomAesKey :: TVar ChaChaDRG -> STM Key
|
||||
randomAesKey = fmap Key . randomBytes aesKeySize
|
||||
{-# INLINE randomAesKey #-}
|
||||
|
||||
randomGCMIV :: TVar ChaChaDRG -> STM GCMIV
|
||||
randomGCMIV = fmap GCMIV . randomBytes gcmIVSize
|
||||
{-# INLINE randomGCMIV #-}
|
||||
|
||||
ivSize :: forall c. AES.BlockCipher c => Int
|
||||
ivSize = AES.blockSize (undefined :: c)
|
||||
{-# INLINE ivSize #-}
|
||||
|
||||
gcmIVSize :: Int
|
||||
gcmIVSize = 12
|
||||
@@ -1101,6 +1120,7 @@ makeIV bs = maybeError CryptoIVError $ AES.makeIV bs
|
||||
|
||||
maybeError :: CryptoError -> Maybe a -> ExceptT CryptoError IO a
|
||||
maybeError e = maybe (throwE e) return
|
||||
{-# INLINE maybeError #-}
|
||||
|
||||
cryptoFailable :: CE.CryptoFailable a -> ExceptT CryptoError IO a
|
||||
cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
@@ -1111,12 +1131,15 @@ cryptoFailable = liftEither . first AESCipherError . CE.eitherCryptoError
|
||||
sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> Signature a
|
||||
sign' (PrivateKeyEd25519 pk k) msg = SignatureEd25519 $ Ed25519.sign pk k msg
|
||||
sign' (PrivateKeyEd448 pk k) msg = SignatureEd448 $ Ed448.sign pk k msg
|
||||
{-# INLINE sign' #-}
|
||||
|
||||
sign :: APrivateSignKey -> ByteString -> ASignature
|
||||
sign (APrivateSignKey a k) = ASignature a . sign' k
|
||||
{-# INLINE sign #-}
|
||||
|
||||
signCertificate :: APrivateSignKey -> Certificate -> SignedCertificate
|
||||
signCertificate = signX509
|
||||
{-# INLINE signCertificate #-}
|
||||
|
||||
signX509 :: (ASN1Object o, Eq o, Show o) => APrivateSignKey -> o -> SignedExact o
|
||||
signX509 key = fst . objectToSignedExact f
|
||||
@@ -1141,6 +1164,7 @@ verifyX509 key exact = do
|
||||
|
||||
certificateFingerprint :: SignedCertificate -> KeyHash
|
||||
certificateFingerprint = signedFingerprint
|
||||
{-# INLINE certificateFingerprint #-}
|
||||
|
||||
signedFingerprint :: (ASN1Object o, Eq o, Show o) => SignedExact o -> KeyHash
|
||||
signedFingerprint o = KeyHash fp
|
||||
@@ -1154,16 +1178,20 @@ instance SignatureAlgorithm a => SignatureAlgorithmX509 (SAlgorithm a) where
|
||||
signatureAlgorithmX509 = \case
|
||||
SEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
|
||||
SEd448 -> SignatureALG_IntrinsicHash PubKeyALG_Ed448
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
instance SignatureAlgorithmX509 APrivateSignKey where
|
||||
signatureAlgorithmX509 (APrivateSignKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
instance SignatureAlgorithmX509 APublicVerifyKey where
|
||||
signatureAlgorithmX509 (APublicVerifyKey a _) = signatureAlgorithmX509 a
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | An instance for 'ASignatureKeyPair' / ('PublicKeyType' pk, pk), without touching its type family.
|
||||
instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where
|
||||
signatureAlgorithmX509 = signatureAlgorithmX509 . snd
|
||||
{-# INLINE signatureAlgorithmX509 #-}
|
||||
|
||||
-- | A wrapper to marshall signed ASN1 objects, like certificates.
|
||||
newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a}
|
||||
@@ -1198,6 +1226,7 @@ certChainP = do
|
||||
verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool
|
||||
verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig
|
||||
verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig
|
||||
{-# INLINE verify' #-}
|
||||
|
||||
verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool
|
||||
verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of
|
||||
@@ -1207,25 +1236,35 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
|
||||
dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
|
||||
dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk _) = DhSecretX25519 $ X25519.dh k pk
|
||||
dh' (PublicKeyX448 k) (PrivateKeyX448 pk _) = DhSecretX448 $ X448.dh k pk
|
||||
{-# INLINE dh' #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce.
|
||||
cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret
|
||||
{-# INLINE cbEncrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding).
|
||||
cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString
|
||||
cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce
|
||||
{-# INLINE cbEncryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt (SbKey key) = sbEncrypt_ key
|
||||
{-# INLINE sbEncrypt #-}
|
||||
|
||||
sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString
|
||||
sbEncrypt_ secret (CbNonce nonce) msg paddedLen = cryptoBox secret nonce <$> pad msg paddedLen
|
||||
{-# INLINE sbEncrypt_ #-}
|
||||
|
||||
sbEncryptNoPad :: SbKey -> CbNonce -> ByteString -> ByteString
|
||||
sbEncryptNoPad (SbKey key) (CbNonce nonce) = cryptoBox key nonce
|
||||
{-# INLINE sbEncryptNoPad #-}
|
||||
|
||||
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
|
||||
cbEncryptMaxLenBS :: KnownNat i => DhSecret X25519 -> CbNonce -> MaxLenBS i -> ByteString
|
||||
cbEncryptMaxLenBS (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce . unMaxLenBS . padMaxLenBS
|
||||
{-# INLINE cbEncryptMaxLenBS #-}
|
||||
|
||||
cryptoBox :: ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
|
||||
cryptoBox secret nonce s = BA.convert tag <> c
|
||||
@@ -1236,18 +1275,26 @@ cryptoBox secret nonce s = BA.convert tag <> c
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
|
||||
cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret
|
||||
{-# INLINE cbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret
|
||||
{-# INLINE cbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce.
|
||||
sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt (SbKey key) = sbDecrypt_ key
|
||||
{-# INLINE sbDecrypt #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
|
||||
sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce
|
||||
{-# INLINE sbDecrypt_ #-}
|
||||
|
||||
sbDecryptNoPad :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
sbDecryptNoPad (SbKey key) = sbDecryptNoPad_ key
|
||||
{-# INLINE sbDecryptNoPad #-}
|
||||
|
||||
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
|
||||
sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString
|
||||
@@ -1356,20 +1403,23 @@ newtype SbChainKey = SecretBoxChainKey {unSbChainKey :: ByteString}
|
||||
sbcInit :: ByteArrayAccess secret => ByteString -> secret -> (SbChainKey, SbChainKey)
|
||||
sbcInit salt secret = (SecretBoxChainKey ck1, SecretBoxChainKey ck2)
|
||||
where
|
||||
prk = H.extract salt secret :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChainInit" :: ByteString) 64
|
||||
(ck1, ck2) = B.splitAt 32 out
|
||||
(ck1, ck2) = B.splitAt 32 $ hkdf salt secret "SimpleXSbChainInit" 64
|
||||
|
||||
type SbKeyNonce = (SbKey, CbNonce)
|
||||
|
||||
sbcHkdf :: SbChainKey -> (SbKeyNonce, SbChainKey)
|
||||
sbcHkdf (SecretBoxChainKey ck) = ((SecretBoxKey sk, CryptoBoxNonce nonce), SecretBoxChainKey ck')
|
||||
where
|
||||
prk = H.extract B.empty ck :: H.PRK SHA512
|
||||
out = H.expand prk ("SimpleXSbChain" :: ByteString) 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
out = hkdf "" ck "SimpleXSbChain" 88 -- = 32 (new chain key) + 32 (secret_box key) + 24 (nonce)
|
||||
(ck', rest) = B.splitAt 32 out
|
||||
(sk, nonce) = B.splitAt 32 rest
|
||||
|
||||
hkdf :: ByteArrayAccess secret => ByteString -> secret -> ByteString -> Int -> ByteString
|
||||
hkdf salt ikm info n =
|
||||
let prk = H.extract salt ikm :: H.PRK SHA512
|
||||
in H.expand prk info n
|
||||
{-# INLINE hkdf #-}
|
||||
|
||||
xSalsa20 :: ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
|
||||
xSalsa20 secret nonce msg = (rs, msg')
|
||||
where
|
||||
|
||||
@@ -94,8 +94,6 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Cipher.AES (AES256)
|
||||
import Crypto.Hash (SHA512)
|
||||
import qualified Crypto.KDF.HKDF as H
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson as J
|
||||
@@ -1130,8 +1128,7 @@ chainKdf (RatchetKey ck) =
|
||||
hkdf3 :: ByteString -> ByteString -> ByteString -> (ByteString, ByteString, ByteString)
|
||||
hkdf3 salt ikm info = (s1, s2, s3)
|
||||
where
|
||||
prk = H.extract salt ikm :: H.PRK SHA512
|
||||
out = H.expand prk info 96
|
||||
out = hkdf salt ikm info 96
|
||||
(s1, rest) = B.splitAt 32 out
|
||||
(s2, s3) = B.splitAt 32 rest
|
||||
|
||||
|
||||
@@ -0,0 +1,65 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Crypto.ShortLink where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Simplex.Messaging.Agent.Client (cryptoError)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Protocol (EntityId (..), LinkId, EncDataBytes (..), QueueLinkData)
|
||||
|
||||
contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey)
|
||||
contactShortLinkKdf (LinkKey k) =
|
||||
let (lnkId, sbKey) = B.splitAt 24 $ C.hkdf "" k "SimpleXContactLink" 56
|
||||
in (EntityId lnkId, C.unsafeSbKey sbKey)
|
||||
|
||||
invShortLinkKdf :: LinkKey -> C.SbKey
|
||||
invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32
|
||||
|
||||
encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString))
|
||||
encodeSignLinkData (sigKey, pk) agentVRange connReq userData =
|
||||
let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq}
|
||||
ud = smpEncode UserLinkData {agentVRange, userData}
|
||||
in (LinkKey (C.sha3_256 fd), (sign fd, sign ud))
|
||||
where
|
||||
sign s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s
|
||||
|
||||
-- TODO [short links] possibly use padded encryption for fixed and for user data
|
||||
encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> IO QueueLinkData
|
||||
encryptLinkData g k = bimapM encrypt encrypt
|
||||
where
|
||||
encrypt s = do
|
||||
nonce <- atomically $ C.randomCbNonce g
|
||||
pure $ EncDataBytes $ smpEncode nonce <> C.sbEncryptNoPad k nonce s
|
||||
|
||||
decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo)
|
||||
decryptLinkData linkKey k (encFD, encUD) = do
|
||||
(sig1, fd) <- decrypt encFD
|
||||
(sig2, ud) <- decrypt encUD
|
||||
FixedLinkData {sigKey, connReq} <- decode fd
|
||||
UserLinkData {userData} <- decode ud
|
||||
if
|
||||
| LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash"
|
||||
| not (C.verify' sigKey sig1 fd) -> linkErr "link data signature"
|
||||
| not (C.verify' sigKey sig2 ud) -> linkErr "user data signature"
|
||||
| otherwise -> Right (connReq, userData)
|
||||
where
|
||||
decrypt (EncDataBytes d) = do
|
||||
(nonce, Tail ct) <- decode d
|
||||
(sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecryptNoPad k nonce ct)
|
||||
(,s) <$> msgErr (C.decodeSignature sigBytes)
|
||||
decode :: Encoding a => ByteString -> Either AgentErrorType a
|
||||
decode = msgErr . smpDecode
|
||||
msgErr = first (const $ AGENT A_MESSAGE)
|
||||
linkErr = Left . AGENT . A_LINK
|
||||
@@ -58,6 +58,14 @@ module Simplex.Messaging.Protocol
|
||||
Command (..),
|
||||
SubscriptionMode (..),
|
||||
SenderCanSecure,
|
||||
NewQueueReq (..),
|
||||
QueueReqData (..),
|
||||
QueueMode (..),
|
||||
QueueLinkData,
|
||||
EncFixedDataBytes,
|
||||
EncUserDataBytes,
|
||||
EncDataBytes (..),
|
||||
NewNtfCreds (..),
|
||||
Party (..),
|
||||
Cmd (..),
|
||||
DirectParty,
|
||||
@@ -65,6 +73,7 @@ module Simplex.Messaging.Protocol
|
||||
SParty (..),
|
||||
PartyI (..),
|
||||
QueueIdsKeys (..),
|
||||
ServerNtfCreds (..),
|
||||
ProtocolErrorType (..),
|
||||
ErrorType (..),
|
||||
CommandError (..),
|
||||
@@ -108,6 +117,7 @@ module Simplex.Messaging.Protocol
|
||||
QueueId,
|
||||
RecipientId,
|
||||
SenderId,
|
||||
LinkId,
|
||||
NotifierId,
|
||||
RcvPrivateAuthKey,
|
||||
RcvPublicAuthKey,
|
||||
@@ -140,6 +150,8 @@ module Simplex.Messaging.Protocol
|
||||
MsgFlags (..),
|
||||
initialSMPClientVersion,
|
||||
currentSMPClientVersion,
|
||||
senderCanSecure,
|
||||
queueReqMode,
|
||||
userProtocol,
|
||||
rcvMessageMeta,
|
||||
noMsgFlags,
|
||||
@@ -215,6 +227,7 @@ import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
|
||||
import qualified GHC.TypeLits as TE
|
||||
import qualified GHC.TypeLits as Type
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
@@ -281,7 +294,7 @@ e2eEncMessageLength :: Int
|
||||
e2eEncMessageLength = 16000 -- 15988 .. 16005
|
||||
|
||||
-- | SMP protocol clients
|
||||
data Party = Recipient | Sender | Notifier | ProxiedClient
|
||||
data Party = Recipient | Sender | Notifier | LinkClient | ProxiedClient
|
||||
deriving (Show)
|
||||
|
||||
-- | Singleton types for SMP protocol clients
|
||||
@@ -289,12 +302,14 @@ data SParty :: Party -> Type where
|
||||
SRecipient :: SParty Recipient
|
||||
SSender :: SParty Sender
|
||||
SNotifier :: SParty Notifier
|
||||
SLinkClient :: SParty LinkClient
|
||||
SProxiedClient :: SParty ProxiedClient
|
||||
|
||||
instance TestEquality SParty where
|
||||
testEquality SRecipient SRecipient = Just Refl
|
||||
testEquality SSender SSender = Just Refl
|
||||
testEquality SNotifier SNotifier = Just Refl
|
||||
testEquality SLinkClient SLinkClient = Just Refl
|
||||
testEquality SProxiedClient SProxiedClient = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
@@ -308,12 +323,15 @@ instance PartyI Sender where sParty = SSender
|
||||
|
||||
instance PartyI Notifier where sParty = SNotifier
|
||||
|
||||
instance PartyI LinkClient where sParty = SLinkClient
|
||||
|
||||
instance PartyI ProxiedClient where sParty = SProxiedClient
|
||||
|
||||
type family DirectParty (p :: Party) :: Constraint where
|
||||
DirectParty Recipient = ()
|
||||
DirectParty Sender = ()
|
||||
DirectParty Notifier = ()
|
||||
DirectParty LinkClient = ()
|
||||
DirectParty p =
|
||||
(Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not direct"))
|
||||
|
||||
@@ -377,6 +395,8 @@ type SenderId = QueueId
|
||||
-- | SMP queue ID for notifications.
|
||||
type NotifierId = QueueId
|
||||
|
||||
type LinkId = QueueId
|
||||
|
||||
-- | SMP queue ID on the server.
|
||||
type QueueId = EntityId
|
||||
|
||||
@@ -395,9 +415,11 @@ data Command (p :: Party) where
|
||||
-- v6 of SMP servers only support signature algorithm for command authorization.
|
||||
-- v7 of SMP servers additionally support additional layer of authenticated encryption.
|
||||
-- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys.
|
||||
NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> SenderCanSecure -> Command Recipient
|
||||
NEW :: NewQueueReq -> Command Recipient
|
||||
SUB :: Command Recipient
|
||||
KEY :: SndPublicAuthKey -> Command Recipient
|
||||
LSET :: LinkId -> QueueLinkData -> Command Recipient
|
||||
LDEL :: Command Recipient
|
||||
NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
|
||||
NDEL :: Command Recipient
|
||||
GET :: Command Recipient
|
||||
@@ -411,6 +433,9 @@ data Command (p :: Party) where
|
||||
-- SEND :: MsgBody -> Command Sender
|
||||
SEND :: MsgFlags -> MsgBody -> Command Sender
|
||||
PING :: Command Sender
|
||||
-- Client accessing short links
|
||||
LKEY :: SndPublicAuthKey -> Command LinkClient
|
||||
LGET :: Command LinkClient
|
||||
-- SMP notification subscriber commands
|
||||
NSUB :: Command Notifier
|
||||
PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
|
||||
@@ -427,9 +452,58 @@ data Command (p :: Party) where
|
||||
|
||||
deriving instance Show (Command p)
|
||||
|
||||
data NewQueueReq = NewQueueReq
|
||||
{ rcvAuthKey :: RcvPublicAuthKey,
|
||||
rcvDhKey :: RcvPublicDhKey,
|
||||
auth_ :: Maybe BasicAuth,
|
||||
subMode :: SubscriptionMode,
|
||||
queueReqData :: Maybe QueueReqData,
|
||||
ntfCreds :: Maybe NewNtfCreds
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data SubscriptionMode = SMSubscribe | SMOnlyCreate
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- SenderId must be computed client-side as `sha3-256(corr_id)`, `corr_id` - a random transmission ID.
|
||||
-- The server must verify and reject it if it does not match (and in case of collision).
|
||||
-- This allows to include SenderId in FixedDataBytes in full connection request,
|
||||
-- and at the same time prevents the possibility of checking whether a queue with a known ID exists.
|
||||
data QueueReqData = QRMessaging (Maybe (SenderId, QueueLinkData)) | QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
|
||||
deriving (Show)
|
||||
|
||||
queueReqMode :: QueueReqData -> QueueMode
|
||||
queueReqMode = \case
|
||||
QRMessaging _ -> QMMessaging
|
||||
QRContact _ -> QMContact
|
||||
|
||||
senderCanSecure :: Maybe QueueMode -> Bool
|
||||
senderCanSecure = \case
|
||||
Just QMMessaging -> True
|
||||
_ -> False
|
||||
|
||||
type QueueLinkData = (EncFixedDataBytes, EncUserDataBytes)
|
||||
|
||||
type EncFixedDataBytes = EncDataBytes
|
||||
|
||||
type EncUserDataBytes = EncDataBytes
|
||||
|
||||
newtype EncDataBytes = EncDataBytes ByteString
|
||||
deriving (Eq, Show)
|
||||
deriving newtype (FromField, StrEncoding)
|
||||
|
||||
instance Encoding EncDataBytes where
|
||||
smpEncode (EncDataBytes s) = smpEncode (Large s)
|
||||
{-# INLINE smpEncode #-}
|
||||
smpP = EncDataBytes . unLarge <$> smpP
|
||||
{-# INLINE smpP #-}
|
||||
|
||||
instance ToField EncDataBytes where
|
||||
toField (EncDataBytes s) = toField (Binary s)
|
||||
{-# INLINE toField #-}
|
||||
|
||||
data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)
|
||||
|
||||
instance StrEncoding SubscriptionMode where
|
||||
strEncode = \case
|
||||
SMSubscribe -> "subscribe"
|
||||
@@ -449,6 +523,20 @@ instance Encoding SubscriptionMode where
|
||||
'C' -> pure SMOnlyCreate
|
||||
_ -> fail "bad SubscriptionMode"
|
||||
|
||||
instance Encoding QueueReqData where
|
||||
smpEncode = \case
|
||||
QRMessaging d -> smpEncode ('M', d)
|
||||
QRContact d -> smpEncode ('C', d)
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'M' -> QRMessaging <$> smpP
|
||||
'C' -> QRContact <$> smpP
|
||||
_ -> fail "bad QueueReqData"
|
||||
|
||||
instance Encoding NewNtfCreds where
|
||||
smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
|
||||
smpP = NewNtfCreds <$> smpP <*> smpP
|
||||
|
||||
type SenderCanSecure = Bool
|
||||
|
||||
newtype EncTransmission = EncTransmission ByteString
|
||||
@@ -474,6 +562,7 @@ newtype EncFwdTransmission = EncFwdTransmission ByteString
|
||||
data BrokerMsg where
|
||||
-- SMP broker messages (responses, client messages, notifications)
|
||||
IDS :: QueueIdsKeys -> BrokerMsg
|
||||
LNK :: SenderId -> QueueLinkData -> BrokerMsg
|
||||
-- MSG v1/2 has to be supported for encoding/decoding
|
||||
-- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
|
||||
-- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
|
||||
@@ -679,6 +768,8 @@ data CommandTag (p :: Party) where
|
||||
NEW_ :: CommandTag Recipient
|
||||
SUB_ :: CommandTag Recipient
|
||||
KEY_ :: CommandTag Recipient
|
||||
LSET_ :: CommandTag Recipient
|
||||
LDEL_ :: CommandTag Recipient
|
||||
NKEY_ :: CommandTag Recipient
|
||||
NDEL_ :: CommandTag Recipient
|
||||
GET_ :: CommandTag Recipient
|
||||
@@ -689,6 +780,8 @@ data CommandTag (p :: Party) where
|
||||
SKEY_ :: CommandTag Sender
|
||||
SEND_ :: CommandTag Sender
|
||||
PING_ :: CommandTag Sender
|
||||
LKEY_ :: CommandTag LinkClient
|
||||
LGET_ :: CommandTag LinkClient
|
||||
PRXY_ :: CommandTag ProxiedClient
|
||||
PFWD_ :: CommandTag ProxiedClient
|
||||
RFWD_ :: CommandTag Sender
|
||||
@@ -702,6 +795,7 @@ deriving instance Show CmdTag
|
||||
|
||||
data BrokerMsgTag
|
||||
= IDS_
|
||||
| LNK_
|
||||
| MSG_
|
||||
| NID_
|
||||
| NMSG_
|
||||
@@ -729,6 +823,8 @@ instance PartyI p => Encoding (CommandTag p) where
|
||||
NEW_ -> "NEW"
|
||||
SUB_ -> "SUB"
|
||||
KEY_ -> "KEY"
|
||||
LSET_ -> "LSET"
|
||||
LDEL_ -> "LDEL"
|
||||
NKEY_ -> "NKEY"
|
||||
NDEL_ -> "NDEL"
|
||||
GET_ -> "GET"
|
||||
@@ -739,6 +835,8 @@ instance PartyI p => Encoding (CommandTag p) where
|
||||
SKEY_ -> "SKEY"
|
||||
SEND_ -> "SEND"
|
||||
PING_ -> "PING"
|
||||
LKEY_ -> "LKEY"
|
||||
LGET_ -> "LGET"
|
||||
PRXY_ -> "PRXY"
|
||||
PFWD_ -> "PFWD"
|
||||
RFWD_ -> "RFWD"
|
||||
@@ -750,6 +848,8 @@ instance ProtocolMsgTag CmdTag where
|
||||
"NEW" -> Just $ CT SRecipient NEW_
|
||||
"SUB" -> Just $ CT SRecipient SUB_
|
||||
"KEY" -> Just $ CT SRecipient KEY_
|
||||
"LSET" -> Just $ CT SRecipient LSET_
|
||||
"LDEL" -> Just $ CT SRecipient LDEL_
|
||||
"NKEY" -> Just $ CT SRecipient NKEY_
|
||||
"NDEL" -> Just $ CT SRecipient NDEL_
|
||||
"GET" -> Just $ CT SRecipient GET_
|
||||
@@ -760,6 +860,8 @@ instance ProtocolMsgTag CmdTag where
|
||||
"SKEY" -> Just $ CT SSender SKEY_
|
||||
"SEND" -> Just $ CT SSender SEND_
|
||||
"PING" -> Just $ CT SSender PING_
|
||||
"LKEY" -> Just $ CT SLinkClient LKEY_
|
||||
"LGET" -> Just $ CT SLinkClient LGET_
|
||||
"PRXY" -> Just $ CT SProxiedClient PRXY_
|
||||
"PFWD" -> Just $ CT SProxiedClient PFWD_
|
||||
"RFWD" -> Just $ CT SSender RFWD_
|
||||
@@ -776,6 +878,7 @@ instance PartyI p => ProtocolMsgTag (CommandTag p) where
|
||||
instance Encoding BrokerMsgTag where
|
||||
smpEncode = \case
|
||||
IDS_ -> "IDS"
|
||||
LNK_ -> "LNK"
|
||||
MSG_ -> "MSG"
|
||||
NID_ -> "NID"
|
||||
NMSG_ -> "NMSG"
|
||||
@@ -793,6 +896,7 @@ instance Encoding BrokerMsgTag where
|
||||
instance ProtocolMsgTag BrokerMsgTag where
|
||||
decodeTag = \case
|
||||
"IDS" -> Just IDS_
|
||||
"LNK" -> Just LNK_
|
||||
"MSG" -> Just MSG_
|
||||
"NID" -> Just NID_
|
||||
"NMSG" -> Just NMSG_
|
||||
@@ -1138,10 +1242,19 @@ data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId,
|
||||
sndId :: SenderId,
|
||||
rcvPublicDhKey :: RcvPublicDhKey,
|
||||
sndSecure :: SenderCanSecure
|
||||
queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
|
||||
linkId :: Maybe LinkId,
|
||||
serverNtfCreds :: Maybe ServerNtfCreds
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding ServerNtfCreds where
|
||||
smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
|
||||
smpP = ServerNtfCreds <$> smpP <*> smpP
|
||||
|
||||
-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
|
||||
--
|
||||
-- Only used by SMP agent, kept here so its definition is close to respective public key.
|
||||
@@ -1368,14 +1481,17 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -
|
||||
instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
type Tag (Command p) = CommandTag p
|
||||
encodeProtocol v = \case
|
||||
NEW rKey dhKey auth_ subMode sndSecure
|
||||
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, sndSecure)
|
||||
NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
| v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
|
||||
| v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
|
||||
| otherwise -> new <> auth <> e subMode
|
||||
where
|
||||
new = e (NEW_, ' ', rKey, dhKey)
|
||||
auth = maybe "" (e . ('A',)) auth_
|
||||
SUB -> e SUB_
|
||||
KEY k -> e (KEY_, ' ', k)
|
||||
LSET lnkId d -> e (LSET_, ' ', lnkId, d)
|
||||
LDEL -> e LDEL_
|
||||
NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
|
||||
NDEL -> e NDEL_
|
||||
GET -> e GET_
|
||||
@@ -1387,6 +1503,8 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
|
||||
PING -> e PING_
|
||||
NSUB -> e NSUB_
|
||||
LKEY k -> e (LKEY_, ' ', k)
|
||||
LGET -> e LGET_
|
||||
PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
|
||||
PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
|
||||
RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
|
||||
@@ -1409,15 +1527,10 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
SEND {}
|
||||
| B.null entId -> Left $ CMD NO_ENTITY
|
||||
| otherwise -> Right cmd
|
||||
SKEY _
|
||||
| isNothing auth || B.null entId -> Left $ CMD NO_AUTH
|
||||
| otherwise -> Right cmd
|
||||
LGET -> entityCmd
|
||||
PING -> noAuthCmd
|
||||
PRXY {} -> noAuthCmd
|
||||
PFWD {}
|
||||
| B.null entId -> Left $ CMD NO_ENTITY
|
||||
| isNothing auth -> Right cmd
|
||||
| otherwise -> Left $ CMD HAS_AUTH
|
||||
PFWD {} -> entityCmd
|
||||
RFWD _ -> noAuthCmd
|
||||
-- other client commands must have both signature and queue ID
|
||||
_
|
||||
@@ -1429,6 +1542,11 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
noAuthCmd
|
||||
| isNothing auth && B.null entId = Right cmd
|
||||
| otherwise = Left $ CMD HAS_AUTH
|
||||
entityCmd :: Either ErrorType (Command p)
|
||||
entityCmd
|
||||
| B.null entId = Left $ CMD NO_ENTITY
|
||||
| isNothing auth = Right cmd
|
||||
| otherwise = Left $ CMD HAS_AUTH
|
||||
|
||||
instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
type Tag Cmd = CmdTag
|
||||
@@ -1438,13 +1556,24 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
CT SRecipient tag ->
|
||||
Cmd SRecipient <$> case tag of
|
||||
NEW_
|
||||
| v >= sndAuthKeySMPVersion -> new <*> smpP <*> smpP <*> smpP
|
||||
| otherwise -> new <*> auth <*> smpP <*> pure False
|
||||
| v >= shortLinksSMPVersion -> NEW <$> new smpP smpP smpP
|
||||
| v >= sndAuthKeySMPVersion -> NEW <$> new smpP (qReq <$> smpP) (pure Nothing)
|
||||
| otherwise -> NEW <$> new auth (pure Nothing) (pure Nothing)
|
||||
where
|
||||
new = NEW <$> _smpP <*> smpP
|
||||
new p1 p2 p3 = do
|
||||
rcvAuthKey <- _smpP
|
||||
rcvDhKey <- smpP
|
||||
auth_ <- p1
|
||||
subMode <- smpP
|
||||
queueReqData <- p2
|
||||
ntfCreds <- p3
|
||||
pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
|
||||
auth = optional (A.char 'A' *> smpP)
|
||||
qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
|
||||
SUB_ -> pure SUB
|
||||
KEY_ -> KEY <$> _smpP
|
||||
LSET_ -> LSET <$> _smpP <*> smpP
|
||||
LDEL_ -> pure LDEL
|
||||
NKEY_ -> NKEY <$> _smpP <*> smpP
|
||||
NDEL_ -> pure NDEL
|
||||
GET_ -> pure GET
|
||||
@@ -1458,6 +1587,10 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
|
||||
PING_ -> pure PING
|
||||
RFWD_ -> RFWD <$> (EncFwdTransmission . unTail <$> _smpP)
|
||||
CT SLinkClient tag ->
|
||||
Cmd SLinkClient <$> case tag of
|
||||
LKEY_ -> LKEY <$> _smpP
|
||||
LGET_ -> pure LGET
|
||||
CT SProxiedClient tag ->
|
||||
Cmd SProxiedClient <$> case tag of
|
||||
PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP)
|
||||
@@ -1472,11 +1605,13 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
type Tag BrokerMsg = BrokerMsgTag
|
||||
encodeProtocol v = \case
|
||||
IDS (QIK rcvId sndId srvDh sndSecure)
|
||||
| v >= sndAuthKeySMPVersion -> ids <> e sndSecure
|
||||
IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serverNtfCreds}
|
||||
| v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId <> e serverNtfCreds
|
||||
| v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
|
||||
| otherwise -> ids
|
||||
where
|
||||
ids = e (IDS_, ' ', rcvId, sndId, srvDh)
|
||||
LNK sId d -> e (LNK_, ' ', sId, d)
|
||||
MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
|
||||
e (MSG_, ' ', msgId, Tail body)
|
||||
NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
|
||||
@@ -1505,10 +1640,14 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
where
|
||||
bodyP = EncRcvMsgBody . unTail <$> smpP
|
||||
IDS_
|
||||
| v >= sndAuthKeySMPVersion -> ids smpP
|
||||
| otherwise -> ids $ pure False
|
||||
| v >= shortLinksSMPVersion -> ids smpP smpP smpP
|
||||
| v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing
|
||||
| otherwise -> ids nothing nothing nothing
|
||||
where
|
||||
ids p = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p)
|
||||
qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
nothing = pure Nothing
|
||||
ids p1 p2 p3 = IDS <$> (QIK <$> _smpP <*> smpP <*> smpP <*> p1 <*> p2 <*> p3)
|
||||
LNK_ -> LNK <$> _smpP <*> smpP
|
||||
NID_ -> NID <$> _smpP <*> smpP
|
||||
NMSG_ -> NMSG <$> _smpP <*> smpP
|
||||
PKEY_ -> PKEY <$> _smpP <*> smpP <*> ((,) <$> C.certChainP <*> (C.getSignedExact <$> smpP))
|
||||
|
||||
+103
-70
@@ -849,8 +849,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
q <- liftIO $ getQueueRec st SSender sId
|
||||
liftIO $ hPutStrLn h $ case q of
|
||||
Left e -> "error: " <> show e
|
||||
Right (_, QueueRec {sndSecure, status, updatedAt}) ->
|
||||
"status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", sndSecure: " <> show sndSecure
|
||||
Right (_, QueueRec {queueMode, status, updatedAt}) ->
|
||||
"status: " <> show status <> ", updatedAt: " <> show updatedAt <> ", queueMode: " <> show queueMode
|
||||
CPBlock sId info -> withUserRole $ unliftIO u $ do
|
||||
AMS _ _ (st :: s) <- asks msgStore
|
||||
r <- liftIO $ runExceptT $ do
|
||||
@@ -1060,13 +1060,15 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail
|
||||
verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M (VerificationResult s)
|
||||
verifyTransmission ms auth_ tAuth authorized queueId cmd =
|
||||
case cmd of
|
||||
Cmd SRecipient (NEW k _ _ _ _) -> pure $ Nothing `verifiedWith` k
|
||||
Cmd SRecipient (NEW NewQueueReq {rcvAuthKey = k}) -> pure $ Nothing `verifiedWith` k
|
||||
Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey (snd 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 -> if maybe True (k ==) (senderKey $ snd q) then Just q `verifiedWith` k else dummyVerify) <$> get SSender
|
||||
Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey $ snd q)) <$> get SSender
|
||||
Cmd SSender (SKEY k) -> verifySecure SSender k
|
||||
-- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command
|
||||
Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender
|
||||
Cmd SSender PING -> pure $ VRVerified Nothing
|
||||
Cmd SSender RFWD {} -> pure $ VRVerified Nothing
|
||||
Cmd SLinkClient (LKEY k) -> verifySecure SLinkClient k
|
||||
Cmd SLinkClient LGET -> verifyQueue (\q -> if isContact (snd q) then VRVerified (Just q) else VRFailed) <$> get SLinkClient
|
||||
-- NSUB will not be accepted without authorization
|
||||
Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (\n -> Just q `verifiedWith` notifierKey n) (notifier $ snd q)) <$> get SNotifier
|
||||
Cmd SProxiedClient _ -> pure $ VRVerified Nothing
|
||||
@@ -1075,9 +1077,16 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd =
|
||||
dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed
|
||||
verifyQueue :: ((StoreQueue s, QueueRec) -> VerificationResult s) -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s
|
||||
verifyQueue = either (const dummyVerify)
|
||||
verified q cond = if cond then VRVerified q else VRFailed
|
||||
verifySecure :: DirectParty p => SParty p -> SndPublicAuthKey -> M (VerificationResult s)
|
||||
verifySecure p k = verifyQueue (\q -> if k `allowedKey` snd q then Just q `verifiedWith` k else dummyVerify) <$> get p
|
||||
verifiedWith :: Maybe (StoreQueue s, QueueRec) -> C.APublicAuthKey -> VerificationResult s
|
||||
verifiedWith q k = q `verified` verify k
|
||||
verifiedWith q_ k = if verify k then VRVerified q_ else VRFailed
|
||||
allowedKey k = \case
|
||||
QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey
|
||||
_ -> False
|
||||
isContact = \case
|
||||
QueueRec {queueMode = Just QMContact} -> True
|
||||
_ -> False
|
||||
get :: DirectParty p => SParty p -> M (Either ErrorType (StoreQueue s, QueueRec))
|
||||
get party = liftIO $ getQueueRec ms party queueId
|
||||
|
||||
@@ -1233,84 +1242,106 @@ client
|
||||
processCommand clntVersion (q_, (corrId, entId, cmd)) = case cmd of
|
||||
Cmd SProxiedClient command -> processProxiedCmd (corrId, entId, command)
|
||||
Cmd SSender command -> Just <$> case command of
|
||||
SKEY sKey ->
|
||||
withQueue $ \q QueueRec {sndSecure} ->
|
||||
(corrId,entId,) <$> if sndSecure then secureQueue_ q sKey else pure $ ERR AUTH
|
||||
SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k
|
||||
SEND flags msgBody -> withQueue_ False $ sendMessage flags msgBody
|
||||
PING -> pure (corrId, NoEntity, PONG)
|
||||
RFWD encBlock -> (corrId, NoEntity,) <$> processForwardedCommand encBlock
|
||||
Cmd SLinkClient command -> Just <$> case command of
|
||||
LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
|
||||
LGET -> withQueue $ \q qr -> checkMode QMContact qr $ getQueueLink_ q qr
|
||||
Cmd SNotifier NSUB -> Just <$> subscribeNotifications
|
||||
Cmd SRecipient command ->
|
||||
Just <$> case command of
|
||||
NEW rKey dhKey auth subMode sndSecure ->
|
||||
ifM
|
||||
allowNew
|
||||
(createQueue rKey dhKey subMode sndSecure)
|
||||
(pure (corrId, entId, ERR AUTH))
|
||||
-- TODO [short links] idempotent NEW
|
||||
NEW nqr@NewQueueReq {auth_} ->
|
||||
ifM allowNew (createQueue nqr) (pure (corrId, entId, ERR AUTH))
|
||||
where
|
||||
allowNew = do
|
||||
ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
|
||||
pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
|
||||
pure $ allowNewQueues && maybe True ((== auth_) . Just) newQueueBasicAuth
|
||||
SUB -> withQueue subscribeQueue
|
||||
GET -> withQueue getMessage
|
||||
ACK msgId -> withQueue $ acknowledgeMsg msgId
|
||||
KEY sKey -> withQueue $ \q _ -> (corrId,entId,) <$> secureQueue_ q sKey
|
||||
KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey
|
||||
LSET lnkId d ->
|
||||
withQueue $ \q qr -> checkMode QMContact qr $ liftIO $
|
||||
OK <$$ addQueueLinkData (queueStore ms) q lnkId d
|
||||
LDEL ->
|
||||
withQueue $ \q _ -> liftIO $ (corrId,entId,) . either ERR (const OK) <$>
|
||||
deleteQueueLinkData (queueStore ms) q
|
||||
NKEY nKey dhKey -> withQueue $ \q _ -> addQueueNotifier_ q nKey dhKey
|
||||
NDEL -> withQueue $ \q _ -> deleteQueueNotifier_ q
|
||||
OFF -> maybe (pure $ err INTERNAL) suspendQueue_ q_
|
||||
DEL -> maybe (pure $ err INTERNAL) delQueueAndMsgs q_
|
||||
QUE -> withQueue $ \q qr -> (corrId,entId,) <$> getQueueInfo q qr
|
||||
where
|
||||
createQueue :: RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> SenderCanSecure -> M (Transmission BrokerMsg)
|
||||
createQueue recipientKey dhKey subMode sndSecure = time "NEW" $ do
|
||||
(rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random
|
||||
createQueue :: NewQueueReq -> M (Transmission BrokerMsg)
|
||||
createQueue NewQueueReq {rcvAuthKey, rcvDhKey, subMode, queueReqData, ntfCreds} = time "NEW" $ do
|
||||
g <- asks random
|
||||
idSize <- asks $ queueIdBytes . config
|
||||
updatedAt <- Just <$> liftIO getSystemDate
|
||||
let rcvDhSecret = C.dh' dhKey privDhKey
|
||||
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey, sndSecure}
|
||||
qRec senderId =
|
||||
QueueRec
|
||||
{ senderId,
|
||||
recipientKey,
|
||||
rcvDhSecret,
|
||||
senderKey = Nothing,
|
||||
notifier = Nothing,
|
||||
status = EntityActive,
|
||||
sndSecure,
|
||||
updatedAt
|
||||
}
|
||||
(corrId,entId,) <$> addQueueRetry 3 qik qRec
|
||||
where
|
||||
addQueueRetry ::
|
||||
Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> (SenderId -> QueueRec) -> M BrokerMsg
|
||||
addQueueRetry 0 _ _ = pure $ ERR INTERNAL
|
||||
addQueueRetry n qik qRec = do
|
||||
ids@(rId, sId) <- getIds
|
||||
let qr = qRec sId
|
||||
liftIO (addQueue ms rId qr) >>= \case
|
||||
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
|
||||
Left e -> pure $ ERR e
|
||||
Right q -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qCreated stats
|
||||
incStat $ qCount stats
|
||||
case subMode of
|
||||
SMOnlyCreate -> pure ()
|
||||
SMSubscribe -> void $ subscribeQueue q qr
|
||||
pure $ IDS (qik ids)
|
||||
(rcvPublicDhKey, privDhKey) <- atomically $ C.generateKeyPair g
|
||||
ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do
|
||||
(ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey)
|
||||
let randId = EntityId <$> atomically (C.randomBytes idSize g)
|
||||
tryCreate 0 = pure $ ERR INTERNAL
|
||||
tryCreate n = do
|
||||
(sndId, clntIds, queueData) <- case queueReqData of
|
||||
Just (QRMessaging (Just (sId, d))) -> (\linkId -> (sId, True, Just (linkId, d))) <$> randId
|
||||
Just (QRContact (Just (linkId, (sId, d)))) -> pure (sId, True, Just (linkId, d))
|
||||
_ -> (,False,Nothing) <$> randId
|
||||
-- The condition that client-provided sender ID must match hash of correlation ID
|
||||
-- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check
|
||||
-- if queue with this ID still exists.
|
||||
if clntIds && unEntityId sndId /= C.sha3_256 (bs corrId)
|
||||
then pure $ ERR $ CMD PROHIBITED
|
||||
else do
|
||||
rcvId <- randId
|
||||
ntf <- forM ntfKeys_ $ \(notifierKey, rcvNtfDhSecret, rcvPubDhKey) -> do
|
||||
notifierId <- randId
|
||||
pure (NtfCreds {notifierId, notifierKey, rcvNtfDhSecret}, ServerNtfCreds notifierId rcvPubDhKey)
|
||||
let queueMode = queueReqMode <$> queueReqData
|
||||
qr =
|
||||
QueueRec
|
||||
{ senderId = sndId,
|
||||
recipientKey = rcvAuthKey,
|
||||
rcvDhSecret = C.dh' rcvDhKey privDhKey,
|
||||
senderKey = Nothing,
|
||||
queueMode,
|
||||
queueData,
|
||||
notifier = fst <$> ntf,
|
||||
status = EntityActive,
|
||||
updatedAt
|
||||
}
|
||||
liftIO (addQueue ms rcvId qr) >>= \case
|
||||
Left DUPLICATE_ -- TODO [short links] possibly, we somehow need to understand which IDs caused collision to retry if it's not client-supplied?
|
||||
| clntIds -> pure $ ERR AUTH -- no retry on collision if sender ID is client-supplied
|
||||
| otherwise -> tryCreate (n - 1)
|
||||
Left e -> pure $ ERR e
|
||||
Right q -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qCreated stats
|
||||
incStat $ qCount stats
|
||||
when (isJust ntf) $ incStat $ ntfCreated stats
|
||||
case subMode of
|
||||
SMOnlyCreate -> pure ()
|
||||
SMSubscribe -> void $ subscribeQueue q qr
|
||||
pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId = fst <$> queueData, serverNtfCreds = snd <$> ntf}
|
||||
(corrId,entId,) <$> tryCreate (3 :: Int)
|
||||
|
||||
getIds :: M (RecipientId, SenderId)
|
||||
getIds = do
|
||||
n <- asks $ queueIdBytes . config
|
||||
liftM2 (,) (randomId n) (randomId n)
|
||||
checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg)
|
||||
checkMode qm QueueRec {queueMode} a =
|
||||
(corrId,entId,) . either ERR id
|
||||
<$> if queueMode == Just qm then a else pure $ Left AUTH
|
||||
|
||||
secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M BrokerMsg
|
||||
secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M (Either ErrorType BrokerMsg)
|
||||
secureQueue_ q sKey = do
|
||||
liftIO (secureQueue (queueStore ms) q sKey) >>= \case
|
||||
Left e -> pure $ ERR e
|
||||
Right () -> do
|
||||
stats <- asks serverStats
|
||||
incStat $ qSecured stats
|
||||
pure OK
|
||||
liftIO (secureQueue (queueStore ms) q sKey)
|
||||
$>> (asks serverStats >>= incStat . qSecured) $> Right OK
|
||||
|
||||
getQueueLink_ :: StoreQueue s -> QueueRec -> M (Either ErrorType BrokerMsg)
|
||||
getQueueLink_ q qr = liftIO $ LNK (senderId qr) <$$> getQueueLinkData (queueStore ms) q entId
|
||||
|
||||
addQueueNotifier_ :: StoreQueue s -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> M (Transmission BrokerMsg)
|
||||
addQueueNotifier_ q notifierKey dhKey = time "NKEY" $ do
|
||||
@@ -1617,7 +1648,7 @@ client
|
||||
pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta}
|
||||
|
||||
processForwardedCommand :: EncFwdTransmission -> M BrokerMsg
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR id) . runExceptT $ do
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR RRES) . runExceptT $ do
|
||||
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
|
||||
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
|
||||
let proxyNonce = C.cbNonce $ bs corrId
|
||||
@@ -1652,7 +1683,7 @@ client
|
||||
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
|
||||
stats <- asks serverStats
|
||||
incStat $ pMsgFwdsRecv stats
|
||||
pure $ RRES r3
|
||||
pure r3
|
||||
where
|
||||
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe (StoreQueue s, QueueRec), Transmission Cmd))
|
||||
rejectOrVerify clntThAuth (tAuth, authorized, (corrId', entId', cmdOrError)) =
|
||||
@@ -1665,6 +1696,8 @@ client
|
||||
allowed = case cmd' of
|
||||
Cmd SSender SEND {} -> True
|
||||
Cmd SSender (SKEY _) -> True
|
||||
Cmd SLinkClient (LKEY _) -> True
|
||||
Cmd SLinkClient LGET -> True
|
||||
_ -> False
|
||||
verified = \case
|
||||
VRVerified q -> Right (q, (corrId', entId', cmd'))
|
||||
@@ -1720,12 +1753,12 @@ client
|
||||
|
||||
getQueueInfo :: StoreQueue s -> QueueRec -> M BrokerMsg
|
||||
getQueueInfo q QueueRec {senderKey, notifier} = do
|
||||
fmap (either ERR id) $ liftIO $ runExceptT $ do
|
||||
fmap (either ERR INFO) $ liftIO $ runExceptT $ do
|
||||
qiSub <- liftIO $ TM.lookupIO entId subscriptions >>= mapM mkQSub
|
||||
qiSize <- getQueueSize ms q
|
||||
qiMsg <- toMsgInfo <$$> tryPeekMsg ms q
|
||||
let info = QueueInfo {qiSnd = isJust senderKey, qiNtf = isJust notifier, qiSub, qiSize, qiMsg}
|
||||
pure $ INFO info
|
||||
pure info
|
||||
where
|
||||
mkQSub Sub {subThread, delivered} = do
|
||||
qSubThread <- case subThread of
|
||||
@@ -1787,7 +1820,7 @@ exportMessages :: MsgStoreClass s => Bool -> s -> FilePath -> Bool -> IO ()
|
||||
exportMessages tty ms f drainMsgs = do
|
||||
logInfo $ "saving messages to file " <> T.pack f
|
||||
liftIO $ withFile f WriteMode $ \h ->
|
||||
tryAny (unsafeWithAllMsgQueues tty ms $ saveQueueMsgs h) >>= \case
|
||||
tryAny (unsafeWithAllMsgQueues tty True ms $ saveQueueMsgs h) >>= \case
|
||||
Right (Sum total) -> logInfo $ "messages saved: " <> tshow total
|
||||
Left e -> do
|
||||
logError $ "error exporting messages: " <> tshow e
|
||||
@@ -1824,7 +1857,7 @@ processServerMessages StartOptions {skipWarnings} = do
|
||||
run processValidateQueue
|
||||
| otherwise = logWarn "skipping message expiration" $> Nothing
|
||||
where
|
||||
run a = unsafeWithAllMsgQueues False ms a `catchAny` \_ -> exitFailure
|
||||
run a = unsafeWithAllMsgQueues False False ms a `catchAny` \_ -> exitFailure
|
||||
processExpireQueue :: Int64 -> JournalQueue s -> IO MessageStats
|
||||
processExpireQueue old q = unsafeRunStore q "processExpireQueue" $ do
|
||||
mq <- getMsgQueue ms q False
|
||||
|
||||
@@ -210,7 +210,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
|
||||
let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCConsole, deletedTTL = iniDeletedTTL ini}
|
||||
ps <- newJournalMsgStore $ PQStoreCfg storeCfg
|
||||
sl <- openWriteStoreLog False storeLogFilePath
|
||||
Sum qCnt <- foldQueueRecs True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
||||
Sum qCnt <- foldQueueRecs True True (postgresQueueStore ps) Nothing $ \(rId, qr) -> logCreateQueue sl rId qr $> Sum (1 :: Int)
|
||||
putStrLn $ "Export completed: " <> show qCnt <> " queues"
|
||||
putStrLn $ case readStoreType ini of
|
||||
Right (ASType SQSPostgres SMSJournal) -> "store_queues set to `database`, update it to `memory` in INI file."
|
||||
|
||||
@@ -321,6 +321,12 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where
|
||||
{-# INLINE addQueue_ #-}
|
||||
getQueue_ = withQS getQueue_
|
||||
{-# INLINE getQueue_ #-}
|
||||
addQueueLinkData = withQS addQueueLinkData
|
||||
{-# INLINE addQueueLinkData #-}
|
||||
getQueueLinkData = withQS getQueueLinkData
|
||||
{-# INLINE getQueueLinkData #-}
|
||||
deleteQueueLinkData = withQS deleteQueueLinkData
|
||||
{-# INLINE deleteQueueLinkData #-}
|
||||
secureQueue = withQS secureQueue
|
||||
{-# INLINE secureQueue #-}
|
||||
addQueueNotifier = withQS addQueueNotifier
|
||||
@@ -389,11 +395,11 @@ instance MsgStoreClass (JournalMsgStore s) where
|
||||
|
||||
-- This function can only be used in server CLI commands or before server is started.
|
||||
-- It does not cache queues and is NOT concurrency safe.
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
|
||||
unsafeWithAllMsgQueues tty ms action = case queueStore_ ms of
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> JournalMsgStore s -> (JournalQueue s -> IO a) -> IO a
|
||||
unsafeWithAllMsgQueues tty withData ms action = case queueStore_ ms of
|
||||
MQStore st -> withLoadedQueues st run
|
||||
#if defined(dbServerPostgres)
|
||||
PQStore st -> foldQueueRecs tty st Nothing $ uncurry (mkTempQueue ms) >=> run
|
||||
PQStore st -> foldQueueRecs tty withData st Nothing $ uncurry (mkTempQueue ms) >=> run
|
||||
#endif
|
||||
where
|
||||
run q = do
|
||||
@@ -413,7 +419,7 @@ instance MsgStoreClass (JournalMsgStore s) where
|
||||
#if defined(dbServerPostgres)
|
||||
PQStore st -> do
|
||||
let JournalMsgStore {queueLocks, sharedLock} = ms
|
||||
foldQueueRecs tty st (Just veryOld) $ \(rId, qr) -> do
|
||||
foldQueueRecs tty False st (Just veryOld) $ \(rId, qr) -> do
|
||||
q <- mkTempQueue ms rId qr
|
||||
withSharedWaitLock rId queueLocks sharedLock $ run $ tryStore' "deleteExpiredMsgs" rId $
|
||||
getLoadedQueue q >>= unStoreIO . expireQueueMsgs ms now old
|
||||
|
||||
@@ -80,7 +80,7 @@ instance MsgStoreClass STMMsgStore where
|
||||
{-# INLINE closeMsgStore #-}
|
||||
withActiveMsgQueues = withLoadedQueues . queueStore_
|
||||
{-# INLINE withActiveMsgQueues #-}
|
||||
unsafeWithAllMsgQueues _ = withLoadedQueues . queueStore_
|
||||
unsafeWithAllMsgQueues _ _ = withLoadedQueues . queueStore_
|
||||
{-# INLINE unsafeWithAllMsgQueues #-}
|
||||
|
||||
expireOldMessages :: Bool -> STMMsgStore -> Int64 -> Int64 -> IO MessageStats
|
||||
|
||||
@@ -37,7 +37,8 @@ class (Monad (StoreMonad s), QueueStoreClass (StoreQueue s) (QueueStore s)) => M
|
||||
closeMsgStore :: s -> IO ()
|
||||
withActiveMsgQueues :: Monoid a => s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- This function can only be used in server CLI commands or before server is started.
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- tty, withData, store
|
||||
unsafeWithAllMsgQueues :: Monoid a => Bool -> Bool -> s -> (StoreQueue s -> IO a) -> IO a
|
||||
-- tty, store, now, ttl
|
||||
expireOldMessages :: Bool -> s -> Int64 -> Int64 -> IO MessageStats
|
||||
logQueueStates :: s -> IO ()
|
||||
|
||||
@@ -25,14 +25,15 @@ import Simplex.Messaging.Util (eitherToMaybe)
|
||||
#endif
|
||||
|
||||
data QueueRec = QueueRec
|
||||
{ recipientKey :: !RcvPublicAuthKey,
|
||||
rcvDhSecret :: !RcvDhSecret,
|
||||
senderId :: !SenderId,
|
||||
senderKey :: !(Maybe SndPublicAuthKey),
|
||||
sndSecure :: !SenderCanSecure,
|
||||
notifier :: !(Maybe NtfCreds),
|
||||
status :: !ServerEntityStatus,
|
||||
updatedAt :: !(Maybe RoundedSystemTime)
|
||||
{ recipientKey :: RcvPublicAuthKey,
|
||||
rcvDhSecret :: RcvDhSecret,
|
||||
senderId :: SenderId,
|
||||
senderKey :: Maybe SndPublicAuthKey,
|
||||
queueMode :: Maybe QueueMode,
|
||||
queueData :: Maybe (LinkId, QueueLinkData),
|
||||
notifier :: Maybe NtfCreds,
|
||||
status :: ServerEntityStatus,
|
||||
updatedAt :: Maybe RoundedSystemTime
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
||||
@@ -35,7 +35,6 @@ import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (Builder)
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy as LB
|
||||
import Data.Bitraversable (bimapM)
|
||||
import Data.Either (fromRight)
|
||||
@@ -43,10 +42,10 @@ import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (intersperse)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||
import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError)
|
||||
import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..))
|
||||
import qualified Database.PostgreSQL.Simple as DB
|
||||
import qualified Database.PostgreSQL.Simple.Copy as DB
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
@@ -146,10 +145,11 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
>>= bimapM handleDuplicate pure
|
||||
atomically $ TM.insert rId sq queues
|
||||
atomically $ TM.insert (senderId qr) rId senders
|
||||
forM_ (notifier qr) $ \NtfCreds {notifierId = nId} -> atomically $ TM.insert nId rId notifiers
|
||||
withLog "addStoreQueue" st $ \s -> logCreateQueue s rId qr
|
||||
pure sq
|
||||
where
|
||||
PostgresQueueStore {queues, senders} = st
|
||||
PostgresQueueStore {queues, senders, notifiers} = st
|
||||
-- Not doing duplicate checks in maps as the probability of duplicates is very low.
|
||||
-- It needs to be reconsidered when IDs are supplied by the users.
|
||||
-- hasId = anyM [TM.memberIO rId queues, TM.memberIO senderId senders, hasNotifier]
|
||||
@@ -160,12 +160,14 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
SRecipient -> getRcvQueue qId
|
||||
SSender -> TM.lookupIO qId senders >>= maybe loadSndQueue getRcvQueue
|
||||
SNotifier -> TM.lookupIO qId notifiers >>= maybe loadNtfQueue getRcvQueue
|
||||
SLinkClient -> loadLinkQueue
|
||||
where
|
||||
PostgresQueueStore {queues, senders, notifiers} = st
|
||||
getRcvQueue rId = TM.lookupIO rId queues >>= maybe loadRcvQueue (pure . Right)
|
||||
loadRcvQueue = loadQueue " WHERE recipient_id = ?" $ \_ -> pure ()
|
||||
loadSndQueue = loadQueue " WHERE sender_id = ?" $ \rId -> TM.insert qId rId senders
|
||||
loadNtfQueue = loadQueue " WHERE notifier_id = ?" $ \_ -> pure () -- do NOT cache ref - ntf subscriptions are rare
|
||||
loadLinkQueue = loadQueue " WHERE link_id = ?" $ \_ -> pure ()
|
||||
loadQueue condition insertRef =
|
||||
E.uninterruptibleMask_ $ runExceptT $ do
|
||||
(rId, qRec) <-
|
||||
@@ -187,6 +189,43 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
TM.insert rId sq queues
|
||||
pure sq
|
||||
|
||||
getQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
getQueueLinkData st sq lnkId = runExceptT $ do
|
||||
qr <- ExceptT $ readQueueRecIO $ queueRec sq
|
||||
case queueData qr of
|
||||
Just (lnkId', _) | lnkId' == lnkId ->
|
||||
withDB "getQueueLinkData" st $ \db -> firstRow id AUTH $
|
||||
DB.query db "SELECT fixed_data, user_data FROM msg_queues WHERE link_id = ? AND deleted_at IS NULL" (Only lnkId)
|
||||
_ -> throwE AUTH
|
||||
|
||||
addQueueLinkData :: PostgresQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
addQueueLinkData st sq lnkId d =
|
||||
withQueueRec sq "addQueueLinkData" $ \q -> case queueData q of
|
||||
Nothing ->
|
||||
addLink q $ \db -> DB.execute db qry (d :. (lnkId, rId))
|
||||
Just (lnkId', _) | lnkId' == lnkId ->
|
||||
addLink q $ \db -> DB.execute db (qry <> " AND (fixed_data IS NULL OR fixed_data != ?)") (d :. (lnkId, rId, fst d))
|
||||
_ -> throwE AUTH
|
||||
where
|
||||
rId = recipientId sq
|
||||
addLink q update = do
|
||||
assertUpdated $ withDB' "addQueueLinkData" st update
|
||||
atomically $ writeTVar (queueRec sq) $ Just q {queueData = Just (lnkId, d)}
|
||||
withLog "addQueueLinkData" st $ \s -> logCreateLink s rId lnkId d
|
||||
qry = "UPDATE msg_queues SET fixed_data = ?, user_data = ?, link_id = ? WHERE recipient_id = ? AND deleted_at IS NULL"
|
||||
|
||||
deleteQueueLinkData :: PostgresQueueStore q -> q -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData st sq =
|
||||
withQueueRec sq "deleteQueueLinkData" $ \q -> case queueData q of
|
||||
Just _ -> do
|
||||
assertUpdated $ withDB' "deleteQueueLinkData" st $ \db ->
|
||||
DB.execute db "UPDATE msg_queues SET link_id = NULL, fixed_data = NULL, user_data = NULL WHERE recipient_id = ? AND deleted_at IS NULL" (Only rId)
|
||||
atomically $ writeTVar (queueRec sq) $ Just q {queueData = Nothing}
|
||||
withLog "deleteQueueLinkData" st (`logDeleteLink` rId)
|
||||
_ -> throwE AUTH
|
||||
where
|
||||
rId = recipientId sq
|
||||
|
||||
secureQueue :: PostgresQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
secureQueue st sq sKey =
|
||||
withQueueRec sq "secureQueue" $ \q -> do
|
||||
@@ -320,15 +359,15 @@ insertQueueQuery :: Query
|
||||
insertQueueQuery =
|
||||
[sql|
|
||||
INSERT INTO msg_queues
|
||||
(recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
(recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
|
||||
foldQueueRecs :: Monoid a => Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
|
||||
foldQueueRecs tty st skipOld_ f = do
|
||||
foldQueueRecs :: forall a q. Monoid a => Bool -> Bool -> PostgresQueueStore q -> Maybe Int64 -> ((RecipientId, QueueRec) -> IO a) -> IO a
|
||||
foldQueueRecs tty withData st skipOld_ f = do
|
||||
(n, r) <- withConnection (dbStore st) $ \db ->
|
||||
foldRecs db (0 :: Int, mempty) $ \(i, acc) row -> do
|
||||
r <- f $ rowToQueueRec row
|
||||
foldRecs db (0 :: Int, mempty) $ \(i, acc) qr -> do
|
||||
r <- f qr
|
||||
let !i' = i + 1
|
||||
!acc' = acc <> r
|
||||
when (tty && i' `mod` 100000 == 0) $ putStr (progress i' <> "\r") >> hFlush stdout
|
||||
@@ -336,29 +375,49 @@ foldQueueRecs tty st skipOld_ f = do
|
||||
when tty $ putStrLn $ progress n
|
||||
pure r
|
||||
where
|
||||
foldRecs db = case skipOld_ of
|
||||
Nothing -> DB.fold_ db (queueRecQuery <> " WHERE deleted_at IS NULL")
|
||||
Just old -> DB.fold db (queueRecQuery <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old)
|
||||
foldRecs db acc f' = case skipOld_ of
|
||||
Nothing
|
||||
| withData -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRecWithData
|
||||
| otherwise -> DB.fold_ db (query <> " WHERE deleted_at IS NULL") acc $ \acc' -> f' acc' . rowToQueueRec
|
||||
Just old
|
||||
| withData -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRecWithData
|
||||
| otherwise -> DB.fold db (query <> " WHERE deleted_at IS NULL AND updated_at > ?") (Only old) acc $ \acc' -> f' acc' . rowToQueueRec
|
||||
query = if withData then queueRecQueryWithData else queueRecQuery
|
||||
progress i = "Processed: " <> show i <> " records"
|
||||
|
||||
queueRecQuery :: Query
|
||||
queueRecQuery =
|
||||
[sql|
|
||||
SELECT recipient_id, recipient_key, rcv_dh_secret,
|
||||
sender_id, sender_key, snd_secure,
|
||||
sender_id, sender_key, queue_mode,
|
||||
notifier_id, notifier_key, rcv_ntf_dh_secret,
|
||||
status, updated_at
|
||||
status, updated_at,
|
||||
link_id
|
||||
FROM msg_queues
|
||||
|]
|
||||
|
||||
type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, SenderCanSecure, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime)
|
||||
queueRecQueryWithData :: Query
|
||||
queueRecQueryWithData =
|
||||
[sql|
|
||||
SELECT recipient_id, recipient_key, rcv_dh_secret,
|
||||
sender_id, sender_key, queue_mode,
|
||||
notifier_id, notifier_key, rcv_ntf_dh_secret,
|
||||
status, updated_at,
|
||||
link_id, fixed_data, user_data
|
||||
FROM msg_queues
|
||||
|]
|
||||
|
||||
queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow
|
||||
queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
|
||||
(rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt)
|
||||
type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId)
|
||||
|
||||
queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes)
|
||||
queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
|
||||
(rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_)
|
||||
:. (fst <$> queueData_, snd <$> queueData_)
|
||||
where
|
||||
(linkId_, queueData_) = queueDataColumns queueData
|
||||
|
||||
queueRecToText :: (RecipientId, QueueRec) -> ByteString
|
||||
queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier = n, status, updatedAt}) =
|
||||
queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) =
|
||||
LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n'
|
||||
where
|
||||
tabFields = BB.char7 ',' `intersperse` fields
|
||||
@@ -368,13 +427,17 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s
|
||||
renderField (toField rcvDhSecret),
|
||||
renderField (toField senderId),
|
||||
nullable senderKey,
|
||||
renderField (toField sndSecure),
|
||||
nullable queueMode,
|
||||
nullable (notifierId <$> n),
|
||||
nullable (notifierKey <$> n),
|
||||
nullable (rcvNtfDhSecret <$> n),
|
||||
BB.char7 '"' <> renderField (toField status) <> BB.char7 '"',
|
||||
nullable updatedAt
|
||||
nullable updatedAt,
|
||||
nullable linkId_,
|
||||
nullable (fst <$> queueData_),
|
||||
nullable (snd <$> queueData_)
|
||||
]
|
||||
(linkId_, queueData_) = queueDataColumns queueData
|
||||
nullable :: ToField a => Maybe a -> Builder
|
||||
nullable = maybe mempty (renderField . toField)
|
||||
renderField :: Action -> Builder
|
||||
@@ -385,10 +448,23 @@ queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, s
|
||||
EscapeIdentifier s -> BB.byteString s -- Not used in COPY data
|
||||
Many as -> mconcat (map renderField as)
|
||||
|
||||
queueDataColumns :: Maybe (LinkId, QueueLinkData) -> (Maybe LinkId, Maybe QueueLinkData)
|
||||
queueDataColumns = \case
|
||||
Just (linkId, linkData) -> (Just linkId, Just linkData)
|
||||
Nothing -> (Nothing, Nothing)
|
||||
|
||||
rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec)
|
||||
rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt) =
|
||||
rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) =
|
||||
let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt})
|
||||
queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
|
||||
|
||||
rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec)
|
||||
rowToQueueRecWithData ((rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) =
|
||||
let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_
|
||||
encData = fromMaybe (EncDataBytes "")
|
||||
queueData = (,(encData immutableData_, encData userData_)) <$> linkId_
|
||||
in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt})
|
||||
|
||||
setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ())
|
||||
setStatusDB op st sq status writeLog =
|
||||
@@ -441,4 +517,8 @@ instance FromField (C.DhSecret 'C.X25519) where fromField = blobFieldDecoder str
|
||||
instance ToField C.APublicAuthKey where toField = toField . Binary . C.encodePubKey
|
||||
|
||||
instance FromField C.APublicAuthKey where fromField = blobFieldDecoder C.decodePubKey
|
||||
|
||||
instance ToField EncDataBytes where toField (EncDataBytes s) = toField (Binary s)
|
||||
|
||||
deriving newtype instance FromField EncDataBytes
|
||||
#endif
|
||||
|
||||
@@ -12,7 +12,8 @@ import Text.RawString.QQ (r)
|
||||
serverSchemaMigrations :: [(String, Text, Maybe Text)]
|
||||
serverSchemaMigrations =
|
||||
[ ("20250207_initial", m20250207_initial, Nothing),
|
||||
("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index)
|
||||
("20250319_updated_index", m20250319_updated_index, Just down_m20250319_updated_index),
|
||||
("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -61,3 +62,37 @@ down_m20250319_updated_index =
|
||||
DROP INDEX idx_msg_queues_updated_at;
|
||||
CREATE INDEX idx_msg_queues_deleted_at ON msg_queues (deleted_at);
|
||||
|]
|
||||
|
||||
m20250320_short_links :: Text
|
||||
m20250320_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE msg_queues
|
||||
ADD COLUMN queue_mode TEXT,
|
||||
ADD COLUMN link_id BYTEA,
|
||||
ADD COLUMN fixed_data BYTEA,
|
||||
ADD COLUMN user_data BYTEA;
|
||||
|
||||
UPDATE msg_queues SET queue_mode = 'M' WHERE snd_secure IS TRUE;
|
||||
|
||||
ALTER TABLE msg_queues DROP COLUMN snd_secure;
|
||||
|
||||
CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id);
|
||||
|]
|
||||
|
||||
down_m20250320_short_links :: Text
|
||||
down_m20250320_short_links =
|
||||
T.pack
|
||||
[r|
|
||||
ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE;
|
||||
|
||||
UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M';
|
||||
|
||||
ALTER TABLE
|
||||
DROP COLUMN queue_mode,
|
||||
DROP COLUMN link_id,
|
||||
DROP COLUMN fixed_data,
|
||||
DROP COLUMN user_data;
|
||||
|
||||
DROP INDEX idx_msg_queues_link_id;
|
||||
|]
|
||||
|
||||
@@ -1,3 +1,6 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Messaging.Server.QueueStore.QueueInfo where
|
||||
@@ -12,6 +15,14 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
||||
import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
#endif
|
||||
|
||||
data QueueInfo = QueueInfo
|
||||
{ qiSnd :: Bool,
|
||||
qiNtf :: Bool,
|
||||
@@ -40,6 +51,24 @@ data MsgInfo = MsgInfo
|
||||
data MsgType = MTMessage | MTQuota
|
||||
deriving (Eq, Show)
|
||||
|
||||
data QueueMode = QMMessaging | QMContact deriving (Eq, Show)
|
||||
|
||||
instance Encoding QueueMode where
|
||||
smpEncode = \case
|
||||
QMMessaging -> "M"
|
||||
QMContact -> "C"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'M' -> pure QMMessaging
|
||||
'C' -> pure QMContact
|
||||
_ -> fail "bad QueueMode"
|
||||
|
||||
#if defined(dbServerPostgres)
|
||||
instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8
|
||||
|
||||
instance ToField QueueMode where toField = toField . decodeLatin1 . smpEncode
|
||||
#endif
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "Q") ''QSubThread)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''QSub)
|
||||
|
||||
@@ -44,6 +44,7 @@ data STMQueueStore q = STMQueueStore
|
||||
{ queues :: TMap RecipientId q,
|
||||
senders :: TMap SenderId RecipientId,
|
||||
notifiers :: TMap NotifierId RecipientId,
|
||||
links :: TMap LinkId RecipientId,
|
||||
storeLog :: TVar (Maybe (StoreLog 'WriteMode))
|
||||
}
|
||||
|
||||
@@ -58,8 +59,9 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
queues <- TM.emptyIO
|
||||
senders <- TM.emptyIO
|
||||
notifiers <- TM.emptyIO
|
||||
links <- TM.emptyIO
|
||||
storeLog <- newTVarIO Nothing
|
||||
pure STMQueueStore {queues, senders, notifiers, storeLog}
|
||||
pure STMQueueStore {queues, senders, notifiers, links, storeLog}
|
||||
|
||||
closeQueueStore :: STMQueueStore q -> IO ()
|
||||
closeQueueStore STMQueueStore {queues, senders, notifiers, storeLog} = do
|
||||
@@ -80,17 +82,19 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
pure QueueCounts {queueCount, notifierCount}
|
||||
|
||||
addQueue_ :: STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
|
||||
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier} = do
|
||||
addQueue_ st mkQ rId qr@QueueRec {senderId = sId, notifier, queueData} = do
|
||||
sq <- mkQ rId qr
|
||||
add sq $>> withLog "addStoreQueue" st (\s -> logCreateQueue s rId qr) $> Right sq
|
||||
where
|
||||
STMQueueStore {queues, senders, notifiers} = st
|
||||
STMQueueStore {queues, senders, notifiers, links} = st
|
||||
add q = atomically $ ifM hasId (pure $ Left DUPLICATE_) $ Right () <$ do
|
||||
TM.insert rId q queues
|
||||
TM.insert sId rId senders
|
||||
forM_ notifier $ \NtfCreds {notifierId} -> TM.insert notifierId rId notifiers
|
||||
hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier]
|
||||
forM_ queueData $ \(lnkId, _) -> TM.insert lnkId rId links
|
||||
hasId = anyM [TM.member rId queues, TM.member sId senders, hasNotifier, hasLink]
|
||||
hasNotifier = maybe (pure False) (\NtfCreds {notifierId} -> TM.member notifierId notifiers) notifier
|
||||
hasLink = maybe (pure False) (\(lnkId, _) -> TM.member lnkId links) queueData
|
||||
|
||||
getQueue_ :: DirectParty p => STMQueueStore q -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
|
||||
getQueue_ st _ party qId =
|
||||
@@ -98,8 +102,44 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where
|
||||
SRecipient -> TM.lookupIO qId queues
|
||||
SSender -> TM.lookupIO qId senders $>>= (`TM.lookupIO` queues)
|
||||
SNotifier -> TM.lookupIO qId notifiers $>>= (`TM.lookupIO` queues)
|
||||
SLinkClient -> TM.lookupIO qId links $>>= (`TM.lookupIO` queues)
|
||||
where
|
||||
STMQueueStore {queues, senders, notifiers} = st
|
||||
STMQueueStore {queues, senders, notifiers, links} = st
|
||||
|
||||
getQueueLinkData :: STMQueueStore q -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
getQueueLinkData _ q lnkId = atomically $ readQueueRec (queueRec q) $>>= pure . getData
|
||||
where
|
||||
getData qr = case queueData qr of
|
||||
Just (lnkId', d) | lnkId' == lnkId -> Right d
|
||||
_ -> Left AUTH
|
||||
|
||||
addQueueLinkData :: STMQueueStore q -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
addQueueLinkData st sq lnkId d =
|
||||
atomically (readQueueRec qr $>>= add)
|
||||
$>> withLog "addQueueLinkData" st (\s -> logCreateLink s rId lnkId d)
|
||||
where
|
||||
rId = recipientId sq
|
||||
qr = queueRec sq
|
||||
add q = case queueData q of
|
||||
Nothing -> addLink
|
||||
Just (lnkId', d') | lnkId' == lnkId && fst d' == fst d -> addLink
|
||||
_ -> pure $ Left AUTH
|
||||
where
|
||||
addLink = do
|
||||
let !q' = q {queueData = Just (lnkId, d)}
|
||||
writeTVar qr $ Just q'
|
||||
TM.insert lnkId rId $ links st
|
||||
pure $ Right ()
|
||||
|
||||
deleteQueueLinkData :: STMQueueStore q -> q -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData st sq =
|
||||
withQueueRec qr delete
|
||||
$>> withLog "deleteQueueLinkData" st (`logDeleteLink` recipientId sq)
|
||||
where
|
||||
qr = queueRec sq
|
||||
delete q = forM (queueData q) $ \(lnkId, _) -> do
|
||||
TM.delete lnkId $ links st
|
||||
writeTVar qr $ Just q {queueData = Nothing}
|
||||
|
||||
secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
secureQueue st sq sKey =
|
||||
|
||||
@@ -30,6 +30,9 @@ class StoreQueueClass q => QueueStoreClass q s where
|
||||
compactQueues :: s -> IO Int64
|
||||
addQueue_ :: s -> (RecipientId -> QueueRec -> IO q) -> RecipientId -> QueueRec -> IO (Either ErrorType q)
|
||||
getQueue_ :: DirectParty p => s -> (RecipientId -> QueueRec -> IO q) -> SParty p -> QueueId -> IO (Either ErrorType q)
|
||||
getQueueLinkData :: s -> q -> LinkId -> IO (Either ErrorType QueueLinkData)
|
||||
addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ())
|
||||
deleteQueueLinkData :: s -> q -> IO (Either ErrorType ())
|
||||
secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ())
|
||||
addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId))
|
||||
deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId))
|
||||
|
||||
@@ -18,6 +18,8 @@ module Simplex.Messaging.Server.StoreLog
|
||||
closeStoreLog,
|
||||
writeStoreLogRecord,
|
||||
logCreateQueue,
|
||||
logCreateLink,
|
||||
logDeleteLink,
|
||||
logSecureQueue,
|
||||
logAddNotifier,
|
||||
logSuspendQueue,
|
||||
@@ -37,6 +39,7 @@ import qualified Control.Exception as E
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.List (sort, stripPrefix)
|
||||
@@ -45,6 +48,7 @@ import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
|
||||
import GHC.IO (catchAny)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
-- import Simplex.Messaging.Server.MsgStore.Types
|
||||
@@ -57,6 +61,8 @@ import System.FilePath (takeDirectory, takeFileName)
|
||||
|
||||
data StoreLogRecord
|
||||
= CreateQueue RecipientId QueueRec
|
||||
| CreateLink RecipientId LinkId QueueLinkData
|
||||
| DeleteLink RecipientId
|
||||
| SecureQueue QueueId SndPublicAuthKey
|
||||
| AddNotifier QueueId NtfCreds
|
||||
| SuspendQueue QueueId
|
||||
@@ -69,6 +75,8 @@ data StoreLogRecord
|
||||
|
||||
data SLRTag
|
||||
= CreateQueue_
|
||||
| CreateLink_
|
||||
| DeleteLink_
|
||||
| SecureQueue_
|
||||
| AddNotifier_
|
||||
| SuspendQueue_
|
||||
@@ -79,21 +87,22 @@ data SLRTag
|
||||
| UpdateTime_
|
||||
|
||||
instance StrEncoding QueueRec where
|
||||
strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt} =
|
||||
strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} =
|
||||
B.unwords
|
||||
[ "rk=" <> strEncode recipientKey,
|
||||
"rdh=" <> strEncode rcvDhSecret,
|
||||
"sid=" <> strEncode senderId,
|
||||
"sk=" <> strEncode senderKey
|
||||
]
|
||||
<> sndSecureStr
|
||||
<> maybe "" notifierStr notifier
|
||||
<> maybe "" updatedAtStr updatedAt
|
||||
<> maybe "" ((" queue_mode=" <>) . smpEncode) queueMode
|
||||
<> opt " link_id=" (fst <$> queueData)
|
||||
<> opt " queue_data=" (snd <$> queueData)
|
||||
<> opt " notifier=" notifier
|
||||
<> opt " updated_at=" updatedAt
|
||||
<> statusStr
|
||||
where
|
||||
sndSecureStr = if sndSecure then " sndSecure=" <> strEncode sndSecure else ""
|
||||
notifierStr ntfCreds = " notifier=" <> strEncode ntfCreds
|
||||
updatedAtStr t = " updated_at=" <> strEncode t
|
||||
opt :: StrEncoding a => ByteString -> Maybe a -> ByteString
|
||||
opt param = maybe "" ((param <>) . strEncode)
|
||||
statusStr = case status of
|
||||
EntityActive -> ""
|
||||
_ -> " status=" <> strEncode status
|
||||
@@ -103,15 +112,23 @@ instance StrEncoding QueueRec where
|
||||
rcvDhSecret <- "rdh=" *> strP_
|
||||
senderId <- "sid=" *> strP_
|
||||
senderKey <- "sk=" *> strP
|
||||
sndSecure <- (" sndSecure=" *> strP) <|> pure False
|
||||
queueMode <-
|
||||
toQueueMode <$> (" sndSecure=" *> strP)
|
||||
<|> Just <$> (" queue_mode=" *> smpP)
|
||||
<|> pure Nothing -- unknown queue mode, we cannot imply that it is contact address
|
||||
queueData <- optional $ (,) <$> (" link_id" *> strP) <*> (" queue_data" *> strP)
|
||||
notifier <- optional $ " notifier=" *> strP
|
||||
updatedAt <- optional $ " updated_at=" *> strP
|
||||
status <- (" status=" *> strP) <|> pure EntityActive
|
||||
pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, sndSecure, notifier, status, updatedAt}
|
||||
pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}
|
||||
where
|
||||
toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact
|
||||
|
||||
instance StrEncoding SLRTag where
|
||||
strEncode = \case
|
||||
CreateQueue_ -> "CREATE"
|
||||
CreateLink_ -> "CREATE_LINK"
|
||||
DeleteLink_ -> "DELETE_LINK"
|
||||
SecureQueue_ -> "SECURE"
|
||||
AddNotifier_ -> "NOTIFIER"
|
||||
SuspendQueue_ -> "SUSPEND"
|
||||
@@ -124,6 +141,8 @@ instance StrEncoding SLRTag where
|
||||
strP =
|
||||
A.choice
|
||||
[ "CREATE" $> CreateQueue_,
|
||||
"CREATE_LINK" $> CreateLink_,
|
||||
"DELETE_LINK" $> DeleteLink_,
|
||||
"SECURE" $> SecureQueue_,
|
||||
"NOTIFIER" $> AddNotifier_,
|
||||
"SUSPEND" $> SuspendQueue_,
|
||||
@@ -137,6 +156,8 @@ instance StrEncoding SLRTag where
|
||||
instance StrEncoding StoreLogRecord where
|
||||
strEncode = \case
|
||||
CreateQueue rId q -> B.unwords [strEncode CreateQueue_, "rid=" <> strEncode rId, strEncode q]
|
||||
CreateLink rId lnkId d -> strEncode (CreateLink_, rId, lnkId, d)
|
||||
DeleteLink rId -> strEncode (DeleteLink_, rId)
|
||||
SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey)
|
||||
AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds)
|
||||
SuspendQueue rId -> strEncode (SuspendQueue_, rId)
|
||||
@@ -149,6 +170,8 @@ instance StrEncoding StoreLogRecord where
|
||||
strP =
|
||||
strP_ >>= \case
|
||||
CreateQueue_ -> CreateQueue <$> ("rid=" *> strP_) <*> strP
|
||||
CreateLink_ -> CreateLink <$> strP_ <*> strP_ <*> strP
|
||||
DeleteLink_ -> DeleteLink <$> strP
|
||||
SecureQueue_ -> SecureQueue <$> strP_ <*> strP
|
||||
AddNotifier_ -> AddNotifier <$> strP_ <*> strP
|
||||
SuspendQueue_ -> SuspendQueue <$> strP
|
||||
@@ -189,6 +212,12 @@ writeStoreLogRecord (WriteStoreLog _ h) r = E.uninterruptibleMask_ $ do
|
||||
logCreateQueue :: StoreLog 'WriteMode -> RecipientId -> QueueRec -> IO ()
|
||||
logCreateQueue s rId q = writeStoreLogRecord s $ CreateQueue rId q
|
||||
|
||||
logCreateLink :: StoreLog 'WriteMode -> RecipientId -> LinkId -> QueueLinkData -> IO ()
|
||||
logCreateLink s rId lnkId d = writeStoreLogRecord s $ CreateLink rId lnkId d
|
||||
|
||||
logDeleteLink :: StoreLog 'WriteMode -> RecipientId -> IO ()
|
||||
logDeleteLink s = writeStoreLogRecord s . DeleteLink
|
||||
|
||||
logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO ()
|
||||
logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol
|
||||
import Simplex.Messaging.Protocol (ErrorType, RecipientId, SParty (..))
|
||||
import Simplex.Messaging.Server.QueueStore (QueueRec)
|
||||
import Simplex.Messaging.Server.QueueStore.Types
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
@@ -42,6 +42,8 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine
|
||||
procLogRecord :: StoreLogRecord -> IO ()
|
||||
procLogRecord = \case
|
||||
CreateQueue rId qr -> addQueue_ st mkQ rId qr >>= qError rId "CreateQueue"
|
||||
CreateLink rId lnkId d -> withQueue rId "CreateLink" $ \q -> addQueueLinkData st q lnkId d
|
||||
DeleteLink rId -> withQueue rId "DeleteLink" $ \q -> deleteQueueLinkData st q
|
||||
SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey
|
||||
AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds
|
||||
SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st
|
||||
|
||||
@@ -52,6 +52,7 @@ module Simplex.Messaging.Transport
|
||||
deletedEventSMPVersion,
|
||||
encryptedBlockSMPVersion,
|
||||
blockedEntitySMPVersion,
|
||||
shortLinksSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -147,6 +148,7 @@ smpBlockSize = 16384
|
||||
-- 11 - additional encryption of transport blocks with forward secrecy (10/06/2024)
|
||||
-- 12 - BLOCKED error for blocked queues (1/11/2025)
|
||||
-- 14 - proxyServer handshake property to disable transport encryption between server and proxy (1/19/2025)
|
||||
-- 15 - short links, include creating NTF credentials in NEW command
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -183,6 +185,9 @@ blockedEntitySMPVersion = VersionSMP 12
|
||||
proxyServerHandshakeSMPVersion :: VersionSMP
|
||||
proxyServerHandshakeSMPVersion = VersionSMP 14
|
||||
|
||||
shortLinksSMPVersion :: VersionSMP
|
||||
shortLinksSMPVersion = VersionSMP 15
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 6
|
||||
|
||||
@@ -190,13 +195,13 @@ minServerSMPRelayVersion :: VersionSMP
|
||||
minServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 14
|
||||
currentClientSMPRelayVersion = VersionSMP 15
|
||||
|
||||
legacyServerSMPRelayVersion :: VersionSMP
|
||||
legacyServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 14
|
||||
currentServerSMPRelayVersion = VersionSMP 15
|
||||
|
||||
-- Max SMP protocol version to be used in e2e encrypted
|
||||
-- connection between client and server, as defined by SMP proxy.
|
||||
@@ -204,7 +209,7 @@ currentServerSMPRelayVersion = VersionSMP 14
|
||||
-- to prevent client version fingerprinting by the
|
||||
-- destination relays when clients upgrade at different times.
|
||||
proxiedSMPRelayVersion :: VersionSMP
|
||||
proxiedSMPRelayVersion = VersionSMP 14
|
||||
proxiedSMPRelayVersion = VersionSMP 15
|
||||
|
||||
-- minimal supported protocol version is 6
|
||||
-- TODO remove code that supports sending commands without batching
|
||||
|
||||
+8
-3
@@ -6,7 +6,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module AgentTests (agentTests) where
|
||||
module AgentTests (agentCoreTests, agentTests) where
|
||||
|
||||
import AgentTests.ConnectionRequestTests
|
||||
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
|
||||
@@ -14,6 +14,7 @@ import AgentTests.FunctionalAPITests (functionalAPITests)
|
||||
import AgentTests.MigrationTests (migrationTests)
|
||||
import AgentTests.NotificationTests (notificationTests)
|
||||
import AgentTests.ServerChoice (serverChoiceTests)
|
||||
import AgentTests.ShortLinkTests (shortLinkTests)
|
||||
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
|
||||
import Simplex.Messaging.Transport (ATransport (..))
|
||||
import Test.Hspec
|
||||
@@ -24,11 +25,15 @@ import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
|
||||
import AgentTests.SQLiteTests (storeTests)
|
||||
#endif
|
||||
|
||||
agentTests :: (ATransport, AStoreType) -> Spec
|
||||
agentTests ps = do
|
||||
agentCoreTests :: Spec
|
||||
agentCoreTests = do
|
||||
describe "Migration tests" migrationTests
|
||||
describe "Connection request" connectionRequestTests
|
||||
describe "Double ratchet tests" doubleRatchetTests
|
||||
describe "Short link tests" shortLinkTests
|
||||
|
||||
agentTests :: (ATransport, AStoreType) -> Spec
|
||||
agentTests ps = do
|
||||
#if defined(dbPostgres)
|
||||
after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do
|
||||
#else
|
||||
|
||||
@@ -12,6 +12,8 @@ module AgentTests.ConnectionRequestTests
|
||||
connReqData,
|
||||
queueAddr,
|
||||
testE2ERatchetParams12,
|
||||
contactConnRequest,
|
||||
invConnRequest,
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
@@ -146,7 +148,10 @@ testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448
|
||||
testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing
|
||||
|
||||
connectionRequest :: AConnectionRequestUri
|
||||
connectionRequest = ACR SCMInvitation $ CRInvitationUri connReqData testE2ERatchetParams
|
||||
connectionRequest = ACR SCMInvitation invConnRequest
|
||||
|
||||
invConnRequest :: ConnectionRequestUri 'CMInvitation
|
||||
invConnRequest = CRInvitationUri connReqData testE2ERatchetParams
|
||||
|
||||
connectionRequestSK :: AConnectionRequestUri
|
||||
connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams
|
||||
@@ -164,7 +169,10 @@ connectionRequestNew1 :: AConnectionRequestUri
|
||||
connectionRequestNew1 = ACR SCMInvitation $ CRInvitationUri connReqDataNew1 testE2ERatchetParams
|
||||
|
||||
contactAddress :: AConnectionRequestUri
|
||||
contactAddress = ACR SCMContact $ CRContactUri connReqData
|
||||
contactAddress = ACR SCMContact $ contactConnRequest
|
||||
|
||||
contactConnRequest :: ConnectionRequestUri 'CMContact
|
||||
contactConnRequest = CRContactUri connReqData
|
||||
|
||||
contactAddressV2 :: AConnectionRequestUri
|
||||
contactAddressV2 = ACR SCMContact $ CRContactUri connReqDataV2
|
||||
|
||||
@@ -6,6 +6,7 @@ module AgentTests.EqInstances where
|
||||
|
||||
import Data.Type.Equality
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Client (ProxiedRelay (..))
|
||||
|
||||
instance Eq SomeConn where
|
||||
@@ -25,6 +26,12 @@ deriving instance Eq (DBQueueId q)
|
||||
|
||||
deriving instance Eq ClientNtfCreds
|
||||
|
||||
deriving instance Eq ShortLinkCreds
|
||||
|
||||
deriving instance Eq ContactConnType
|
||||
|
||||
deriving instance Eq (ConnShortLink m)
|
||||
|
||||
deriving instance Show ProxiedRelay
|
||||
|
||||
deriving instance Eq ProxiedRelay
|
||||
|
||||
@@ -55,11 +55,12 @@ module AgentTests.FunctionalAPITests
|
||||
where
|
||||
|
||||
import AgentTests.ConnectionRequestTests (connReqData, queueAddr, testE2ERatchetParams12)
|
||||
import AgentTests.EqInstances ()
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Bifunctor (first, second)
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -249,8 +250,9 @@ inAnyOrder g rs = withFrozenCallStack $ do
|
||||
expected :: a -> (a -> Bool) -> Bool
|
||||
expected r rp = rp r
|
||||
|
||||
createConnection :: AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs cMode clientData = A.createConnection c userId enableNtfs cMode clientData (IKNoPQ PQSupportOn)
|
||||
createConnection :: ConnectionModeI c => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> AE (ConnId, ConnectionRequestUri c)
|
||||
createConnection c userId enableNtfs cMode clientData =
|
||||
fmap (second fst) . A.createConnection c userId enableNtfs cMode Nothing clientData (IKNoPQ PQSupportOn)
|
||||
|
||||
joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
|
||||
joinConnection c userId enableNtfs cReq connInfo subMode = do
|
||||
@@ -306,6 +308,9 @@ functionalAPITests ps = do
|
||||
testAsyncServerOffline ps
|
||||
it "should restore confirmation after client restart" $
|
||||
testAllowConnectionClientRestart ps
|
||||
describe "Short connection links" $ do
|
||||
it "create and get 1-time short link" $ testInviationShortLink ps
|
||||
it "create and get contact short link" $ testContactShortLink ps
|
||||
describe "Message delivery" $ do
|
||||
describe "update connection agent version on received messages" $ do
|
||||
it "should increase if compatible, shouldn'ps decrease" $
|
||||
@@ -607,7 +612,7 @@ runAgentClientTest pqSupport sqSecured viaProxy alice bob baseId =
|
||||
runAgentClientTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
|
||||
(bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing aPQ SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
sqSecured' <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` sqSecured
|
||||
@@ -809,7 +814,7 @@ runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
|
||||
runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
|
||||
(_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
sqSecuredJoin <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
|
||||
@@ -853,7 +858,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b
|
||||
|
||||
runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
|
||||
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
|
||||
(_, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing aPQ SMSubscribe
|
||||
(bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
|
||||
sentMessages abPQEnc alice bobId bob bAliceId
|
||||
(tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
|
||||
@@ -906,7 +911,7 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` ()
|
||||
testRejectContactRequest :: HasCallStack => IO ()
|
||||
testRejectContactRequest =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
(addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
|
||||
(addrConnId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMContact Nothing Nothing IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
|
||||
@@ -1073,6 +1078,42 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
|
||||
disposeAgentClient alice2
|
||||
disposeAgentClient bob
|
||||
|
||||
testInviationShortLink :: HasCallStack => (ATransport, AStoreType) -> IO ()
|
||||
testInviationShortLink ps =
|
||||
withAgentClients3 $ \a b c -> withSmpServer ps $ do
|
||||
let userData = "some user data"
|
||||
(_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe
|
||||
(connReq', userData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
connReq' `shouldBe` connReq
|
||||
userData' `shouldBe` userData
|
||||
-- same user can get invitation link again
|
||||
(connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink
|
||||
connReq2 `shouldBe` connReq
|
||||
userData2 `shouldBe` userData
|
||||
-- another user cannot get the same invitation link
|
||||
runExceptT (getConnShortLink c 1 shortLink) >>= \case
|
||||
Left (SMP _ AUTH) -> pure ()
|
||||
r -> liftIO $ expectationFailure ("unexpected result " <> show r)
|
||||
|
||||
testContactShortLink :: HasCallStack => (ATransport, AStoreType) -> IO ()
|
||||
testContactShortLink ps =
|
||||
withAgentClients3 $ \a b c -> withSmpServer ps $ do
|
||||
let userData = "some user data"
|
||||
(_bobId, (connReq, Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe
|
||||
(connReq', userData') <- runRight $ getConnShortLink b 1 shortLink
|
||||
strDecode (strEncode shortLink) `shouldBe` Right shortLink
|
||||
connReq' `shouldBe` connReq
|
||||
userData' `shouldBe` userData
|
||||
-- same user can get contact link again
|
||||
(connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink
|
||||
connReq2 `shouldBe` connReq
|
||||
userData2 `shouldBe` userData
|
||||
-- another user can get the same contact link
|
||||
(connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink
|
||||
connReq3 `shouldBe` connReq
|
||||
userData3 `shouldBe` userData
|
||||
|
||||
testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
|
||||
testIncreaseConnAgentVersion ps = do
|
||||
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
|
||||
@@ -1760,7 +1801,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn True
|
||||
|
||||
makeConnectionForUsers_ :: HasCallStack => PQSupport -> SndQueueSecured -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
|
||||
makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
|
||||
(bobId, qInfo) <- A.createConnection alice aliceUserId True SCMInvitation Nothing (CR.IKNoPQ pqSupport) SMSubscribe
|
||||
(bobId, (qInfo, Nothing)) <- A.createConnection alice aliceUserId True SCMInvitation Nothing Nothing (CR.IKNoPQ pqSupport) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
|
||||
sqSecured' <- A.joinConnection bob bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
liftIO $ sqSecured' `shouldBe` sqSecured
|
||||
|
||||
@@ -227,6 +227,7 @@ rcvQueue1 =
|
||||
e2eDhSecret = Nothing,
|
||||
sndId = EntityId "2345",
|
||||
sndSecure = True,
|
||||
shortLink = Nothing,
|
||||
status = New,
|
||||
dbQueueId = DBNewQueue,
|
||||
primary = True,
|
||||
@@ -439,6 +440,7 @@ testUpgradeSndConnToDuplex =
|
||||
e2eDhSecret = Nothing,
|
||||
sndId = EntityId "4567",
|
||||
sndSecure = True,
|
||||
shortLink = Nothing,
|
||||
status = New,
|
||||
dbQueueId = DBNewQueue,
|
||||
rcvSwchStatus = Nothing,
|
||||
|
||||
@@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module AgentTests.ShortLinkTests (shortLinkTests) where
|
||||
|
||||
import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest)
|
||||
import Control.Concurrent.STM
|
||||
import Simplex.Messaging.Agent.Protocol (supportedSMPAgentVRange)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.ShortLink as SL
|
||||
import Test.Hspec
|
||||
|
||||
-- TODO [short tests] tests failures
|
||||
shortLinkTests :: Spec
|
||||
shortLinkTests = do
|
||||
it "should encrypt and decrypt invitation short link data" testInvShortLink
|
||||
it "should encrypt and decrypt contact short link data" testContactShortLink
|
||||
|
||||
testInvShortLink :: IO ()
|
||||
testInvShortLink = do
|
||||
-- encrypt
|
||||
g <- C.newRandom
|
||||
sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
|
||||
let userData = "some user data"
|
||||
(linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange invConnRequest userData
|
||||
k = SL.invShortLinkKdf linkKey
|
||||
srvData <- SL.encryptLinkData g k linkData
|
||||
-- decrypt
|
||||
Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData
|
||||
connReq `shouldBe` invConnRequest
|
||||
userData' `shouldBe` userData
|
||||
|
||||
testContactShortLink :: IO ()
|
||||
testContactShortLink = do
|
||||
-- encrypt
|
||||
g <- C.newRandom
|
||||
sigKeys <- atomically $ C.generateKeyPair @'C.Ed25519 g
|
||||
let userData = "some user data"
|
||||
(linkKey, linkData) = SL.encodeSignLinkData sigKeys supportedSMPAgentVRange contactConnRequest userData
|
||||
(_linkId, k) = SL.contactShortLinkKdf linkKey
|
||||
srvData <- SL.encryptLinkData g k linkData
|
||||
-- decrypt
|
||||
Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData
|
||||
connReq `shouldBe` contactConnRequest
|
||||
userData' `shouldBe` userData
|
||||
@@ -39,6 +39,7 @@ import Simplex.Messaging.Server.MsgStore.Journal
|
||||
import Simplex.Messaging.Server.MsgStore.STM
|
||||
import Simplex.Messaging.Server.MsgStore.Types
|
||||
import Simplex.Messaging.Server.QueueStore
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Server.QueueStore.Types
|
||||
import Simplex.Messaging.Server.StoreLog (closeStoreLog, logCreateQueue)
|
||||
import SMPClient (testStoreLogFile, testStoreMsgsDir, testStoreMsgsDir2, testStoreMsgsFile, testStoreMsgsFile2)
|
||||
@@ -109,8 +110,8 @@ deriving instance Eq (JournalState t)
|
||||
|
||||
deriving instance Eq (SJournalType t)
|
||||
|
||||
testNewQueueRec :: TVar ChaChaDRG -> Bool -> IO (RecipientId, QueueRec)
|
||||
testNewQueueRec g sndSecure = do
|
||||
testNewQueueRec :: TVar ChaChaDRG -> QueueMode -> IO (RecipientId, QueueRec)
|
||||
testNewQueueRec g qm = do
|
||||
rId <- atomically $ EntityId <$> C.randomBytes 24 g
|
||||
senderId <- atomically $ EntityId <$> C.randomBytes 24 g
|
||||
(recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g
|
||||
@@ -121,7 +122,8 @@ testNewQueueRec g sndSecure = do
|
||||
rcvDhSecret = C.dh' k pk,
|
||||
senderId,
|
||||
senderKey = Nothing,
|
||||
sndSecure,
|
||||
queueMode = Just qm,
|
||||
queueData = Nothing,
|
||||
notifier = Nothing,
|
||||
status = EntityActive,
|
||||
updatedAt = Nothing
|
||||
@@ -132,7 +134,7 @@ testNewQueueRec g sndSecure = do
|
||||
testGetQueue :: MsgStoreClass s => s -> IO ()
|
||||
testGetQueue ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
runRight_ $ do
|
||||
q <- ExceptT $ addQueue ms rId qr
|
||||
let write s = writeMsg ms q True =<< mkMessage s
|
||||
@@ -175,7 +177,7 @@ testGetQueue ms = do
|
||||
testChangeReadJournal :: MsgStoreClass s => s -> IO ()
|
||||
testChangeReadJournal ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
runRight_ $ do
|
||||
q <- ExceptT $ addQueue ms rId qr
|
||||
let write s = writeMsg ms q True =<< mkMessage s
|
||||
@@ -194,8 +196,8 @@ testChangeReadJournal ms = do
|
||||
testExportImportStore :: JournalMsgStore 'QSMemory -> IO ()
|
||||
testExportImportStore ms = do
|
||||
g <- C.newRandom
|
||||
(rId1, qr1) <- testNewQueueRec g True
|
||||
(rId2, qr2) <- testNewQueueRec g True
|
||||
(rId1, qr1) <- testNewQueueRec g QMMessaging
|
||||
(rId2, qr2) <- testNewQueueRec g QMMessaging
|
||||
sl <- readWriteQueueStore True (mkQueue ms) testStoreLogFile $ queueStore ms
|
||||
runRight_ $ do
|
||||
let write q s = writeMsg ms q True =<< mkMessage s
|
||||
@@ -302,7 +304,7 @@ testQueueState ms = do
|
||||
testMessageState :: JournalMsgStore s -> IO ()
|
||||
testMessageState ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
let dir = msgQueueDirectory ms rId
|
||||
statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
|
||||
write q s = writeMsg ms q True =<< mkMessage s
|
||||
@@ -327,7 +329,7 @@ testMessageState ms = do
|
||||
testRemoveJournals :: JournalMsgStore s -> IO ()
|
||||
testRemoveJournals ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
let dir = msgQueueDirectory ms rId
|
||||
statePath = msgQueueStatePath dir $ B.unpack (B64.encode $ unEntityId rId)
|
||||
write q s = writeMsg ms q True =<< mkMessage s
|
||||
@@ -393,7 +395,7 @@ testRemoveJournals ms = do
|
||||
testRemoveQueueStateBackups :: IO ()
|
||||
testRemoveQueueStateBackups = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
|
||||
ms' <- newMsgStore (testJournalStoreCfg MQStoreCfg) {maxStateLines = 1, expireBackupsAfter = 0, keepMinBackups = 0}
|
||||
-- set expiration time 1 second ahead
|
||||
@@ -429,7 +431,7 @@ testRemoveQueueStateBackups = do
|
||||
testExpireIdleQueues :: IO ()
|
||||
testExpireIdleQueues = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
|
||||
ms <- newMsgStore (testJournalStoreCfg MQStoreCfg) {idleInterval = 0}
|
||||
|
||||
@@ -462,7 +464,7 @@ testExpireIdleQueues = do
|
||||
testReadFileMissing :: JournalMsgStore s -> IO ()
|
||||
testReadFileMissing ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
let write q s = writeMsg ms q True =<< mkMessage s
|
||||
q <- runRight $ do
|
||||
q <- ExceptT $ addQueue ms rId qr
|
||||
@@ -486,7 +488,7 @@ testReadFileMissing ms = do
|
||||
testReadFileMissingSwitch :: JournalMsgStore s -> IO ()
|
||||
testReadFileMissingSwitch ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
q <- writeMessages ms rId qr
|
||||
|
||||
mq <- fromJust <$> readTVarIO (msgQueue q)
|
||||
@@ -504,7 +506,7 @@ testReadFileMissingSwitch ms = do
|
||||
testWriteFileMissing :: JournalMsgStore s -> IO ()
|
||||
testWriteFileMissing ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
q <- writeMessages ms rId qr
|
||||
|
||||
mq <- fromJust <$> readTVarIO (msgQueue q)
|
||||
@@ -527,7 +529,7 @@ testWriteFileMissing ms = do
|
||||
testReadAndWriteFilesMissing :: JournalMsgStore s -> IO ()
|
||||
testReadAndWriteFilesMissing ms = do
|
||||
g <- C.newRandom
|
||||
(rId, qr) <- testNewQueueRec g True
|
||||
(rId, qr) <- testNewQueueRec g QMMessaging
|
||||
q <- writeMessages ms rId qr
|
||||
|
||||
mq <- fromJust <$> readTVarIO (msgQueue q)
|
||||
|
||||
@@ -52,14 +52,15 @@ deriving instance Eq StoreLogRecord
|
||||
|
||||
deriving instance Eq NtfCreds
|
||||
|
||||
-- TODO [short links] test store log with queue data
|
||||
storeLogTests :: Spec
|
||||
storeLogTests =
|
||||
forM_ [False, True] $ \sndSecure -> do
|
||||
forM_ [QMMessaging, QMContact] $ \qm -> do
|
||||
((rId, qr), ntfCreds, date) <- runIO $ do
|
||||
g <- C.newRandom
|
||||
(,,) <$> testNewQueueRec g sndSecure <*> testNtfCreds g <*> getSystemDate
|
||||
(,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate
|
||||
testSMPStoreLog
|
||||
("SMP server store log, sndSecure = " <> show sndSecure)
|
||||
("SMP server store log, queueMode = " <> show qm)
|
||||
[ SLTC
|
||||
{ name = "create new queue",
|
||||
saved = [CreateQueue rId qr],
|
||||
|
||||
@@ -198,6 +198,7 @@ dummyRQ userId server connId rcvId =
|
||||
e2eDhSecret = Nothing,
|
||||
sndId = NoEntity,
|
||||
sndSecure = True,
|
||||
shortLink = Nothing,
|
||||
status = New,
|
||||
dbQueueId = DBQueueId 0,
|
||||
primary = True,
|
||||
|
||||
+41
-11
@@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
@@ -48,7 +49,8 @@ import UnliftIO.STM
|
||||
ntfServerTests :: ATransport -> Spec
|
||||
ntfServerTests t = do
|
||||
describe "Notifications server protocol syntax" $ ntfSyntaxTests t
|
||||
describe "Notification subscriptions" $ testNotificationSubscription t
|
||||
describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY
|
||||
describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW
|
||||
|
||||
ntfSyntaxTests :: ATransport -> Spec
|
||||
ntfSyntaxTests (ATransport t) = do
|
||||
@@ -93,10 +95,9 @@ v .-> key =
|
||||
let J.Object o = v
|
||||
in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
|
||||
|
||||
testNotificationSubscription :: ATransport -> Spec
|
||||
testNotificationSubscription (ATransport t) =
|
||||
-- hangs on Ubuntu 20/22
|
||||
xit' "should create notification subscription and notify when message is received" $ do
|
||||
testNotificationSubscription :: ATransport -> CreateQueueFunc -> Spec
|
||||
testNotificationSubscription (ATransport t) createQueue =
|
||||
it "should create notification subscription and notify when message is received" $ do
|
||||
g <- C.newRandom
|
||||
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
@@ -106,8 +107,7 @@ testNotificationSubscription (ATransport t) =
|
||||
withAPNSMockServer $ \apns ->
|
||||
smpTest2' t $ \rh sh ->
|
||||
ntfTest t $ \nh -> do
|
||||
-- create queue
|
||||
(sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue rh sPub
|
||||
((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) <- createQueue rh sPub nPub
|
||||
-- register and verify token
|
||||
RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
|
||||
APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <-
|
||||
@@ -118,12 +118,9 @@ testNotificationSubscription (ATransport t) =
|
||||
Right code = NtfRegCode <$> C.cbDecrypt dhSecret nonce verification
|
||||
RespNtf "2" _ NROk <- signSendRecvNtf nh tknKey ("2", tId, TVFY code)
|
||||
RespNtf "2a" _ (NRTkn NTActive) <- signSendRecvNtf nh tknKey ("2a", tId, TCHK)
|
||||
-- enable queue notifications
|
||||
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv rh rKey ("3", rId, NKEY nPub rcvNtfPubDhKey)
|
||||
-- ntf server subscribes to queue notifications
|
||||
let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash
|
||||
q = SMPQueueNtf srv nId
|
||||
rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
|
||||
RespNtf "4" _ (NRSubId _subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey)
|
||||
-- send message
|
||||
threadDelay 50000
|
||||
@@ -169,3 +166,36 @@ testNotificationSubscription (ATransport t) =
|
||||
PNMessageData {smpQueue = SMPQueueNtf {smpServer = smpServer3, notifierId = notifierId3}} = L.last pnMsgs2
|
||||
smpServer3 `shouldBe` srv
|
||||
notifierId3 `shouldBe` nId
|
||||
|
||||
type CreateQueueFunc =
|
||||
forall c.
|
||||
Transport c =>
|
||||
THandleSMP c 'TClient ->
|
||||
SndPublicAuthKey ->
|
||||
NtfPublicAuthKey ->
|
||||
IO ((SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret), NotifierId, C.DhSecret 'C.X25519)
|
||||
|
||||
createNtfQueueNKEY :: CreateQueueFunc
|
||||
createNtfQueueNKEY h sPub nPub = do
|
||||
g <- C.newRandom
|
||||
(sId, rId, rKey, rcvDhSecret) <- createAndSecureQueue h sPub
|
||||
-- enable queue notifications
|
||||
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
Resp "3" _ (NID nId rcvNtfSrvPubDhKey) <- signSendRecv h rKey ("3", rId, NKEY nPub rcvNtfPubDhKey)
|
||||
let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
|
||||
pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret)
|
||||
|
||||
createNtfQueueNEW :: CreateQueueFunc
|
||||
createNtfQueueNEW h sPub nPub = do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
(rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g
|
||||
let cmd = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) (Just (NewNtfCreds nPub rcvNtfPubDhKey)))
|
||||
Resp "abcd" NoEntity (IDS (QIK rId sId srvDh _sndSecure _linkId (Just (ServerNtfCreds nId rcvNtfSrvPubDhKey)))) <-
|
||||
signSendRecv h rKey ("abcd", NoEntity, cmd)
|
||||
let dhShared = C.dh' srvDh dhPriv
|
||||
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
||||
(rId', rId) #== "same queue ID"
|
||||
let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey
|
||||
pure ((sId, rId, rKey, dhShared), nId, rcvNtfDhSecret)
|
||||
|
||||
@@ -36,7 +36,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 (..), maxMessageLength, noMsgFlags, pattern NoEntity)
|
||||
import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, QueueReqData (..), RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags, pattern NoEntity)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
|
||||
import Simplex.Messaging.Server.MsgStore.Types (SQSType (..))
|
||||
@@ -53,6 +53,7 @@ import Fixtures
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem)
|
||||
#endif
|
||||
|
||||
-- TODO [short links] secure and get links via proxy
|
||||
smpProxyTests :: SpecWith AStoreType
|
||||
smpProxyTests = do
|
||||
describe "server configuration" $ do
|
||||
@@ -177,7 +178,7 @@ deliverMessagesViaProxy proxyServ relayServ alg unsecuredMsgs securedMsgs = do
|
||||
-- prepare receiving queue
|
||||
(rPub, rPriv) <- atomically $ C.generateAuthKeyPair alg g
|
||||
(rdhPub, rdhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc (rPub, rPriv) rdhPub (Just "correct") SMSubscribe False
|
||||
SMP.QIK {rcvId, sndId, rcvPublicDhKey = srvDh} <- runExceptT' $ createSMPQueue rc Nothing (rPub, rPriv) rdhPub (Just "correct") SMSubscribe (QRMessaging Nothing) Nothing
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh rdhPriv
|
||||
-- get proxy session
|
||||
sess0 <- runExceptT' $ connectSMPProxiedRelay pc relayServ (Just "correct")
|
||||
@@ -224,7 +225,7 @@ agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty
|
||||
agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId =
|
||||
withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
|
||||
withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
|
||||
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
(bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
@@ -280,7 +281,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
|
||||
-- agent connections have to be set up in advance
|
||||
-- otherwise the CONF messages would get mixed with MSG
|
||||
prePair alice bob = do
|
||||
(bobId, qInfo) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
(bobId, (qInfo, Nothing)) <- runExceptT' $ A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- runExceptT' $ A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
@@ -331,7 +332,7 @@ agentViaProxyVersionError =
|
||||
withAgent 1 agentCfg (servers [SMPServer testHost testPort testKeyHash]) testDB $ \alice -> do
|
||||
Left (A.BROKER _ (TRANSPORT TEVersion)) <-
|
||||
withAgent 2 agentCfg (servers [SMPServer testHost2 testPort2 testKeyHash]) testDB2 $ \bob -> runExceptT $ do
|
||||
(_bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
(_bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
pure ()
|
||||
@@ -351,7 +352,7 @@ agentViaProxyRetryOffline = do
|
||||
let pqEnc = CR.PQEncOn
|
||||
withServer $ \_ -> do
|
||||
(aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
|
||||
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
(bobId, (qInfo, Nothing)) <- A.createConnection alice 1 True SCMInvitation Nothing Nothing (CR.IKNoPQ PQSupportOn) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
sqSecured <- A.joinConnection bob 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ sqSecured `shouldBe` True
|
||||
|
||||
+108
-17
@@ -80,12 +80,18 @@ serverTests = do
|
||||
testMsgExpireOnInterval
|
||||
testMsgNOTExpireOnInterval
|
||||
describe "Blocking queues" $ testBlockMessageQueue
|
||||
describe "Short links" $ do
|
||||
testInvQueueLinkData
|
||||
testContactQueueLinkData
|
||||
|
||||
pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
|
||||
pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
|
||||
|
||||
pattern New :: RcvPublicAuthKey -> RcvPublicDhKey -> Command 'Recipient
|
||||
pattern New rPub dhPub = NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRMessaging Nothing)) Nothing)
|
||||
|
||||
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
|
||||
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure)
|
||||
pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh _sndSecure _linkId _srvNtfCreds)
|
||||
|
||||
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
|
||||
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
|
||||
@@ -146,7 +152,7 @@ testCreateSecure =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
|
||||
@@ -211,7 +217,7 @@ testCreateSndSecure =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
|
||||
@@ -225,8 +231,8 @@ testCreateSndSecure =
|
||||
Resp "dabc" sId2 OK <- signSendRecv s sKey ("dabc", sId, SKEY sPub)
|
||||
(sId2, sId) #== "secures queue, same queue ID in response"
|
||||
|
||||
(sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
Resp "abcd" _ err4 <- signSendRecv s sKey ("abcd", sId, SKEY sPub')
|
||||
(sPub', sKey') <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
Resp "abcd" _ err4 <- signSendRecv s sKey' ("abcd", sId, SKEY sPub')
|
||||
(err4, ERR AUTH) #== "rejects if secured with different key"
|
||||
Resp "abcd" _ OK <- signSendRecv s sKey ("abcd", sId, SKEY sPub)
|
||||
|
||||
@@ -258,7 +264,7 @@ testSndSecureProhibited =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" rId1 (Ids _rId sId _srvDh) <- signSendRecv r rKey ("abcd", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)) Nothing))
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
|
||||
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
@@ -273,7 +279,7 @@ testCreateDelete =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
|
||||
@@ -345,7 +351,7 @@ stressTest =
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
rIds <- forM ([1 .. 50] :: [Int]) . const $ do
|
||||
Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "" NoEntity (Ids rId _ _) <- signSendRecv h1 rKey ("", NoEntity, New rPub dhPub)
|
||||
pure rId
|
||||
let subscribeQueues h = forM_ rIds $ \rId -> do
|
||||
Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB)
|
||||
@@ -363,7 +369,7 @@ testAllowNewQueues =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
pure ()
|
||||
|
||||
testDuplex :: SpecWith (ATransport, AStoreType)
|
||||
@@ -373,7 +379,7 @@ testDuplex =
|
||||
g <- C.newRandom
|
||||
(arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", NoEntity, NEW arPub aDhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", NoEntity, New arPub aDhPub)
|
||||
let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv
|
||||
-- aSnd ID is passed to Bob out-of-band
|
||||
|
||||
@@ -389,7 +395,7 @@ testDuplex =
|
||||
|
||||
(brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, NEW brPub bDhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, New brPub bDhPub)
|
||||
let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv
|
||||
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode (unEntityId bSnd))
|
||||
-- "reply_id ..." is ad-hoc, not a part of SMP protocol
|
||||
@@ -428,7 +434,7 @@ testSwitchSub =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1")
|
||||
(ok1, OK) #== "sent test message 1"
|
||||
@@ -849,7 +855,7 @@ createAndSecureQueue h sPub = do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dhShared = C.dh' srvDh dhPriv
|
||||
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub)
|
||||
(rId', rId) #== "same queue ID"
|
||||
@@ -884,7 +890,7 @@ testTiming =
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
|
||||
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe False)
|
||||
Resp "abcd" NoEntity (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
|
||||
Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB)
|
||||
|
||||
@@ -1032,7 +1038,7 @@ testBlockMessageQueue =
|
||||
(rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, NEW rPub dhPub Nothing SMSubscribe True)
|
||||
Resp "abcd" rId1 (Ids rId sId _srvDh) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
|
||||
(rId1, NoEntity) #== "creates queue"
|
||||
pure (rId, sId)
|
||||
|
||||
@@ -1050,6 +1056,91 @@ testBlockMessageQueue =
|
||||
killThread server
|
||||
pure a
|
||||
|
||||
testInvQueueLinkData :: SpecWith (ATransport, AStoreType)
|
||||
testInvQueueLinkData =
|
||||
it "create and access queue short link data for 1-time invitation" $ \(ATransport t, msType) ->
|
||||
smpTest2 t msType $ \r s -> do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
C.CbNonce corrId <- atomically $ C.randomCbNonce g
|
||||
let sId = EntityId $ C.sha3_256 corrId
|
||||
ld = (EncDataBytes "fixed data", EncDataBytes "user data")
|
||||
qrd = QRMessaging $ Just (sId, ld)
|
||||
-- sender ID must be derived from corrId
|
||||
Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMMessaging) (Just lnkId) Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
(sId', sId) #== "should return the same sender ID"
|
||||
corrId' `shouldBe` CorrId corrId
|
||||
-- can't read link data with LGET
|
||||
Resp "2" lnkId' (ERR AUTH) <- sendRecv s ("", "2", lnkId, LGET)
|
||||
lnkId' `shouldBe` lnkId
|
||||
|
||||
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
|
||||
Resp "3a" _ err2 <- sendRecv s ("", "3a", lnkId, LKEY sPub)
|
||||
(err2, ERR (CMD NO_AUTH)) #== "rejects LKEY without signature"
|
||||
|
||||
Resp "3b" _ err2' <- sendRecv s (sampleSig, "3b", lnkId, LKEY sPub)
|
||||
(err2', ERR AUTH) #== "rejects LKEY with wrong signature"
|
||||
|
||||
Resp "4" _ err3 <- signSendRecv s sKey ("4", rId, LKEY sPub)
|
||||
(err3, ERR AUTH) #== "rejects LKEY with recipients's ID"
|
||||
|
||||
Resp "5" lnkId2 (LNK sId2 ld') <- signSendRecv s sKey ("5", lnkId, LKEY sPub)
|
||||
(lnkId2, lnkId) #== "secures queue and returns link data, same link ID in response"
|
||||
(sId2, sId) #== "same sender ID in response"
|
||||
(ld', ld) #== "returns stored data"
|
||||
|
||||
(sPub', sKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
Resp "6" _ err4 <- signSendRecv s sKey' ("6", lnkId, LKEY sPub')
|
||||
(err4, ERR AUTH) #== "rejects if secured with different key"
|
||||
|
||||
Resp "7" _ (LNK sId3 ld2) <- signSendRecv s sKey ("7", lnkId, LKEY sPub)
|
||||
sId3 `shouldBe` sId
|
||||
ld2 `shouldBe` ld
|
||||
|
||||
testContactQueueLinkData :: SpecWith (ATransport, AStoreType)
|
||||
testContactQueueLinkData =
|
||||
it "create and access queue short link data for contact address" $ \(ATransport t, msType) ->
|
||||
smpTest2 t msType $ \r s -> do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
|
||||
C.CbNonce corrId <- atomically $ C.randomCbNonce g
|
||||
lnkId <- EntityId <$> atomically (C.randomBytes 24 g)
|
||||
let sId = EntityId $ C.sha3_256 corrId
|
||||
ld = (EncDataBytes "fixed data", EncDataBytes "user data")
|
||||
qrd = QRContact $ Just (lnkId, (sId, ld))
|
||||
-- sender ID must be derived from corrId
|
||||
Resp "1" NoEntity (ERR (CMD PROHIBITED)) <-
|
||||
signSendRecv r rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
Resp corrId' NoEntity (IDS (QIK rId sId' _srvDh (Just QMContact) (Just lnkId') Nothing)) <-
|
||||
signSendRecv r rKey (corrId, NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just qrd) Nothing))
|
||||
(lnkId', lnkId) #== "should return the same link ID"
|
||||
(sId', sId) #== "should return the same sender ID"
|
||||
corrId' `shouldBe` CorrId corrId
|
||||
-- can't secure queue and read link data with LKEY
|
||||
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
Resp "2" _ (ERR AUTH) <- signSendRecv s sKey ("2", lnkId, LKEY sPub)
|
||||
|
||||
Resp "3" _ err2 <- sendRecv s (sampleSig, "3", lnkId, LGET)
|
||||
(err2, ERR (CMD HAS_AUTH)) #== "rejects LGET with signature"
|
||||
|
||||
Resp "4" _ err3 <- sendRecv s ("", "4", rId, LGET)
|
||||
(err3, ERR AUTH) #== "rejects LGET with recipients's ID"
|
||||
|
||||
Resp "5" lnkId2 (LNK sId2 ld') <- sendRecv s ("", "5", lnkId, LGET)
|
||||
(lnkId2, lnkId) #== "returns link data, same link ID in response"
|
||||
(sId2, sId) #== "same sender ID in response"
|
||||
(ld', ld) #== "returns stored data"
|
||||
|
||||
Resp "6" _ (LNK sId3 ld2) <- sendRecv s ("", "6", lnkId, LGET)
|
||||
sId3 `shouldBe` sId
|
||||
ld2 `shouldBe` ld
|
||||
|
||||
samplePubKey :: C.APublicVerifyKey
|
||||
samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="
|
||||
|
||||
@@ -1075,8 +1166,8 @@ serverSyntaxTests (ATransport t) = do
|
||||
describe "NEW" $ do
|
||||
it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX)
|
||||
it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX)
|
||||
it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
||||
it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, '0', SMSubscribe, False)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
|
||||
it "no signature" $ ("", "dabc", "", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "dabc", "", ERR $ CMD NO_AUTH)
|
||||
it "queue ID" $ (sampleSig, "abcd", "12345678", ((NEW_, ' ', samplePubKey, sampleDhPubKey), ('0', SMSubscribe, Just (QRMessaging Nothing), '0'))) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH)
|
||||
describe "KEY" $ do
|
||||
it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH)
|
||||
it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX)
|
||||
|
||||
+3
-3
@@ -2,7 +2,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
import AgentTests (agentTests)
|
||||
import AgentTests (agentCoreTests, agentTests)
|
||||
import CLITests
|
||||
import Control.Concurrent (threadDelay)
|
||||
import qualified Control.Exception as E
|
||||
@@ -83,10 +83,10 @@ main = do
|
||||
describe "Store log tests" storeLogTests
|
||||
describe "TRcvQueues tests" tRcvQueuesTests
|
||||
describe "Util tests" utilTests
|
||||
describe "Agent core tests" agentCoreTests
|
||||
#if defined(dbServerPostgres)
|
||||
aroundAll_ (postgressBracket testServerDBConnectInfo)
|
||||
$ describe "SMP server via TLS, postgres+jornal message store" $ do
|
||||
describe "SMP syntax" $ serverSyntaxTests (transport @TLS)
|
||||
$ describe "SMP server via TLS, postgres+jornal message store" $
|
||||
before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests
|
||||
#endif
|
||||
describe "SMP server via TLS, jornal message store" $ do
|
||||
|
||||
Reference in New Issue
Block a user