Compare commits

...
Author SHA1 Message Date
John Roberts dfb0be2c0e migration 2022-03-20 14:50:16 +04:00
John Roberts 2e808192de use server IP addresses 2022-03-20 14:48:09 +04:00
John Roberts 5c6ec96d64 make smp servers configurable for running agent (#326) 2022-03-10 10:49:22 +04:00
Evgeny Poberezkin 7a19ab224b make sending confirmation asynchronous (#327)
* make sending confirmation asynchronous

* confirm first queue synchronously (on JOIN, and delete connection on failure), second queue asynchronously (from REPLY msg)

* test to retry JOIN when the first attempt fails

* process confirmation delivery errors
2022-03-02 15:52:45 +00:00
Efim Poberezkin 7a611bed5a configure systemd service restart and increase file descriptors limit for Linode script (#320) 2022-02-26 18:42:16 +04:00
Efim Poberezkin a406159ed4 1.0.3 2022-02-26 18:11:07 +04:00
Efim Poberezkin 14780a47d6 prepare v1.0.3 (#324) 2022-02-26 18:07:11 +04:00
Evgeny Poberezkin 4a66f68c55 reduce server message queue quota to 128 messages (#323) 2022-02-26 17:49:21 +04:00
Evgeny Poberezkin d1e6147adf encode all nullary constructors as objects for sumTypeJSON options 2022-02-25 18:50:04 +00:00
Evgeny Poberezkin 7d1fdadef0 reduce connection handshake expiration to 2 days 2022-02-25 10:57:23 +00:00
Evgeny Poberezkin 09e2e75c42 increase queue sizes (#322)
* increase queue sizes

* remove TODO
2022-02-25 09:02:52 +00:00
Evgeny Poberezkin dff5cad1be make CPP condition depend on HOST OS (#321) 2022-02-18 08:12:08 +00:00
Evgeny Poberezkin c1f5f9d846 flip condition for JSON encoding to make android (tagged objects) default (#319) 2022-02-16 22:38:15 +00:00
Evgeny Poberezkin 9c4778b129 update condition in cabal 2022-02-16 17:28:14 +00:00
Evgeny Poberezkin 137afb68fe conditional JSON options for iOS/Android (#318)
* conditional JSON options for iOS/Android

* update cabal file
2022-02-16 08:58:35 +00:00
Efim Poberezkin 229e2607d7 remove redundant asynchronous connection code (#317) 2022-02-14 21:00:14 +04:00
Efim PoberezkinandEvgeny Poberezkin c380c79560 make new smp client attempt to reconnect on network error (#315)
* make new smp client attempt to reconnect on network error

* reconnect async wip

* remove comments

* trigger tryReconnectClient

* add subscription before trying to take smp client

* move atomically modify asyncClients

* remove logs

* corrections

* don't put error into new smp client TMVar

* UnliftIO async

* re-work

* test for connection to the server that was initially down

* fix tests

* additionally test that bob receives the message after re-connect

* make test independent of event order

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
2022-02-10 14:48:11 +00:00
Efim Poberezkin c9994c3a2c add "yes to migrations" option (#316) 2022-02-07 11:51:39 +04:00
26 changed files with 501 additions and 269 deletions
+12
View File
@@ -1,3 +1,15 @@
# 1.0.3
SMP server:
- Reduce server message queue quota to 128 messages.
SMP agent:
- Add "yes to migrations" option.
- Make new SMP client attempt to reconnect on network error.
- Reduce connection handshake expiration to 2 days.
JSON encoding of types used in simplex-chat, some other minor adjustments.
# 1.0.2
General:
+1 -1
View File
@@ -11,7 +11,7 @@ import Simplex.Messaging.Agent.Server (runSMPAgent)
import Simplex.Messaging.Transport (TLS, Transport (..))
cfg :: AgentConfig
cfg = defaultAgentConfig {smpServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
cfg = defaultAgentConfig {initialSMPServers = L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"]}
logCfg :: LogConfig
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+2 -2
View File
@@ -277,8 +277,8 @@ runServer IniOptions {enableStoreLog, port, enableWebsockets} = do
ServerConfig
{ transports = (port, transport @TLS) : [("80", transport @WS) | enableWebsockets],
tbqSize = 16,
serverTbqSize = 128,
msgQueueQuota = 256,
serverTbqSize = 64,
msgQueueQuota = 128,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
caCertificateFile = caCrtFile,
+1 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 1.0.2
version: 1.0.3
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
@@ -16,3 +16,8 @@ brew install hashicorp/tap/packer
cd ./scripts/smp-server-digitalocean-droplet
DIGITALOCEAN_TOKEN=$YOUR_TOKEN packer build -on-error=ask -color=false ./marketplace-image.json
```
**TODO** (see Linode script)
- Increase file descriptors limit
- Configure Restart for systemd service
+10
View File
@@ -44,6 +44,12 @@ ufw allow ssh
ufw allow https
ufw allow 5223
# Increase file descriptors limit
echo 'fs.file-max = 1000000' >> /etc/sysctl.conf
echo 'fs.inode-max = 1000000' >> /etc/sysctl.conf
echo 'root soft nofile unlimited' >> /etc/security/limits.conf
echo 'root hard nofile unlimited' >> /etc/security/limits.conf
# Download latest release
bin_dir="/opt/simplex/bin"
binary="$bin_dir/smp-server"
@@ -151,6 +157,10 @@ Description=SMP server
[Service]
Type=simple
ExecStart=/bin/sh -c "exec $binary start >> /var/opt/simplex/smp-server.log 2>&1"
Restart=always
RestartSec=10
LimitNOFILE=1000000
LimitNOFILESoft=1000000
[Install]
WantedBy=multi-user.target
+3 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 1.0.2
version: 1.0.3
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
@@ -40,6 +40,8 @@ library
Simplex.Messaging.Agent.Store.SQLite
Simplex.Messaging.Agent.Store.SQLite.Migrations
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220320_server_ips
Simplex.Messaging.Client
Simplex.Messaging.Crypto
Simplex.Messaging.Crypto.Ratchet
+100 -66
View File
@@ -47,6 +47,7 @@ module Simplex.Messaging.Agent
ackMessage,
suspendConnection,
deleteConnection,
setSMPServers,
logConnection,
)
where
@@ -143,6 +144,10 @@ suspendConnection c = withAgentEnv c . suspendConnection' c
deleteConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
deleteConnection c = withAgentEnv c . deleteConnection' c
-- | Change servers to be used for creating new queues
setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers c = withAgentEnv c . setSMPServers' c
withAgentEnv :: AgentClient -> ReaderT Env m a -> m a
withAgentEnv c = (`runReaderT` agentEnv c)
@@ -209,7 +214,7 @@ processCommand c (connId, cmd) = case cmd of
newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequestUri c)
newConn c connId cMode = do
srv <- getSMPServer
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
g <- asks idsDrg
let cData = ConnData {connId}
@@ -234,16 +239,20 @@ joinConn c connId (CRInvitationUri (ConnReqUriData _ agentVRange (qUri :| _)) e2
(pk1, pk2, e2eSndParams) <- liftIO . CR.generateE2EParams $ version e2eRcvParams
(_, rcDHRs) <- liftIO C.generateKeyPair'
let rc = CR.initSndRatchet rcDHRr rcDHRs $ CR.x3dhSnd pk1 pk2 e2eRcvParams
(sq, smpConf) <- newSndQueue qInfo cInfo
sq <- newSndQueue qInfo
g <- asks idsDrg
let cData = ConnData {connId}
connId' <- withStore $ \st -> do
connId' <- createSndConn st g cData sq
createRatchet st connId' rc
pure connId'
confirmQueue c connId' sq smpConf $ Just e2eSndParams
void $ enqueueMessage c connId' sq HELLO
pure connId'
tryError (confirmQueue c connId' sq cInfo $ Just e2eSndParams) >>= \case
Right _ -> do
void $ enqueueMessage c connId' sq HELLO
pure connId'
Left e -> do
withStore (`deleteConn` connId')
throwError e
_ -> throwError $ AGENT A_VERSION
joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInfo =
case ( qUri `compatibleVersion` SMP.smpClientVRange,
@@ -258,7 +267,7 @@ joinConn c connId (CRContactUri (ConnReqUriData _ agentVRange (qUri :| _))) cInf
createReplyQueue :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> m ()
createReplyQueue c connId sq = do
srv <- getSMPServer
srv <- getSMPServer c
(rq, qUri) <- newRcvQueue c srv
-- TODO reply queue version should be the same as send queue, ignoring it in v1
let qInfo = toVersionT qUri SMP.smpClientVersion
@@ -305,16 +314,6 @@ subscribeConnection' c connId =
SomeConn _ (DuplexConnection _ rq sq) -> do
resumeMsgDelivery c connId sq
subscribeQueue c rq connId
case status (sq :: SndQueue) of
Confirmed -> do
-- TODO if there is no confirmation saved, just update the status without securing the queue
AcceptedConfirmation {senderConf = SMPConfirmation {senderKey}} <-
withStore (`getAcceptedConfirmation` connId)
secureQueue c rq senderKey
withStore $ \st -> setRcvQueueStatus st rq Secured
Secured -> pure ()
Active -> pure ()
_ -> throwError $ INTERNAL "unexpected queue status"
SomeConn _ (SndConnection _ sq) -> do
resumeMsgDelivery c connId sq
case status (sq :: SndQueue) of
@@ -347,12 +346,12 @@ enqueueMessage c connId sq aMessage = do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
let privHeader = APrivHeader (unSndId internalSndId) prevMsgHash
agentMessage = smpEncode $ AgentMessage privHeader aMessage
internalHash = C.sha256Hash agentMessage
encAgentMessage <- agentRatchetEncrypt connId agentMessage e2eEncUserMsgLength
agentMsg = AgentMessage privHeader aMessage
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
encAgentMessage <- agentRatchetEncrypt connId agentMsgStr e2eEncUserMsgLength
let msgBody = smpEncode $ AgentMsgEnvelope {agentVersion = smpAgentVersion, encAgentMessage}
msgType = aMessageType aMessage
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, internalHash, prevMsgHash}
withStore $ \st -> createSndMsg st connId msgData
pure internalId
@@ -402,30 +401,38 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
notify $ MERR mId (INTERNAL $ show e)
Right (rq_, (msgType, msgBody, internalTs)) ->
withRetryInterval ri $ \loop ->
tryError (sendAgentMessage c sq msgBody) >>= \case
tryError (send msgType c sq msgBody) >>= \case
Left e -> do
let err = if msgType == AM_CONN_INFO then ERR e else MERR mId e
case e of
SMP SMP.QUOTA -> loop
SMP SMP.QUOTA -> case msgType of
AM_CONN_INFO -> connError msgId NOT_AVAILABLE
_ -> loop
SMP SMP.AUTH -> case msgType of
HELLO_ -> do
AM_CONN_INFO -> connError msgId NOT_AVAILABLE
AM_HELLO_ -> do
helloTimeout <- asks $ helloTimeout . config
currentTime <- liftIO getCurrentTime
if diffUTCTime currentTime internalTs > helloTimeout
then case rq_ of
-- party initiating connection
Just _ -> notifyDel msgId . ERR $ CONN NOT_AVAILABLE
Just _ -> connError msgId NOT_AVAILABLE
-- party joining connection
_ -> notifyDel msgId . ERR $ CONN NOT_ACCEPTED
_ -> connError msgId NOT_ACCEPTED
else loop
REPLY_ -> notifyDel msgId $ ERR e
A_MSG_ -> notifyDel msgId $ MERR mId e
SMP (SMP.CMD _) -> notifyDel msgId $ MERR mId e
SMP SMP.LARGE_MSG -> notifyDel msgId $ MERR mId e
SMP {} -> notify (MERR mId e) >> loop
AM_REPLY_ -> notifyDel msgId $ ERR e
AM_A_MSG_ -> notifyDel msgId $ MERR mId e
SMP (SMP.CMD _) -> notifyDel msgId err
SMP SMP.LARGE_MSG -> notifyDel msgId err
SMP {} -> notify err >> loop
_ -> loop
Right () -> do
case msgType of
HELLO_ -> do
AM_CONN_INFO -> do
withStore $ \st -> setSndQueueStatus st sq Confirmed
when (isJust rq_) $ withStore (`removeConfirmations` connId)
void $ enqueueMessage c connId sq HELLO
AM_HELLO_ -> do
withStore $ \st -> setSndQueueStatus st sq Active
case rq_ of
-- party initiating connection
@@ -434,16 +441,20 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} connId sq = do
notify CON
-- party joining connection
_ -> createReplyQueue c connId sq
A_MSG_ -> notify $ SENT mId
AM_A_MSG_ -> notify $ SENT mId
_ -> pure ()
delMsg msgId
where
send = \case
AM_CONN_INFO -> sendConfirmation
_ -> sendAgentMessage
delMsg :: InternalId -> m ()
delMsg msgId = withStore $ \st -> deleteMsg st connId msgId
notify :: ACommand 'Agent -> m ()
notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd)
notifyDel :: InternalId -> ACommand 'Agent -> m ()
notifyDel msgId cmd = notify cmd >> delMsg msgId
connError msgId = notifyDel msgId . ERR . CONN
ackMessage' :: forall m. AgentMonad m => AgentClient -> ConnId -> AgentMsgId -> m ()
ackMessage' c connId msgId = do
@@ -482,9 +493,15 @@ deleteConnection' c connId =
removeSubscription c connId
withStore (`deleteConn` connId)
getSMPServer :: AgentMonad m => m SMPServer
getSMPServer =
asks (smpServers . config) >>= \case
-- | Change servers to be used for creating new queues, in Reader monad
setSMPServers' :: forall m. AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
setSMPServers' c servers = do
atomically $ writeTVar (smpServers c) servers
getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
getSMPServer c = do
smpServers <- readTVarIO $ smpServers c
case smpServers of
srv :| [] -> pure srv
servers -> do
gen <- asks randomServer
@@ -529,8 +546,9 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
(SMP.PHEmpty, AgentMsgEnvelope _ encAgentMsg) -> do
agentMsgBody <- agentRatchetDecrypt connId encAgentMsg
parseMessage agentMsgBody >>= \case
AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage -> do
(msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) agentMsgBody aMessage
agentMsg@(AgentMessage APrivHeader {sndMsgId, prevMsgHash} aMessage) -> do
let msgType = agentMessageType agentMsg
(msgId, msgMeta) <- agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) agentMsgBody msgType
case aMessage of
HELLO -> helloMsg >> ack >> withStore (\st -> deleteMsg st connId msgId)
REPLY cReq -> replyMsg cReq >> ack >> withStore (\st -> deleteMsg st connId msgId)
@@ -620,15 +638,13 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
case qInfo `proveCompatible` SMP.smpClientVRange of
Nothing -> notify . ERR $ AGENT A_VERSION
Just qInfo' -> do
(sq, smpConf) <- newSndQueue qInfo' ownConnInfo
sq <- newSndQueue qInfo'
withStore $ \st -> upgradeRcvConnToDuplex st connId sq
confirmQueue c connId sq smpConf Nothing
withStore (`removeConfirmations` connId)
void $ enqueueMessage c connId sq HELLO
enqueueConfirmation c connId sq ownConnInfo Nothing
_ -> prohibited
agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> AMessage -> m (InternalId, MsgMeta)
agentClientMsg externalPrevSndHash sndMsgId broker msgBody aMessage = do
agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> AgentMessageType -> m (InternalId, MsgMeta)
agentClientMsg externalPrevSndHash sndMsgId broker msgBody msgType = do
logServer "<--" c srv rId "MSG <MSG>"
let internalHash = C.sha256Hash msgBody
internalTs <- liftIO getCurrentTime
@@ -636,7 +652,6 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash externalPrevSndHash
recipient = (unId internalId, internalTs)
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
msgType = aMessageType aMessage
rcvMsg = RcvMsgData {msgMeta, msgType, msgBody, internalRcvId, internalHash, externalPrevSndHash}
withStore $ \st -> createRcvMsg st connId rcvMsg
pure (internalId, msgMeta)
@@ -661,8 +676,9 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
| internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
| otherwise = MsgError MsgDuplicate -- this case is not possible
confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> SMPConfirmation -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
confirmQueue c connId sq SMPConfirmation {senderKey, e2ePubKey, connInfo} e2eEncryption = do
confirmQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
confirmQueue c connId sq connInfo e2eEncryption = do
_ <- withStore (`updateSndIds` connId)
msg <- mkConfirmation
sendConfirmation c sq msg
withStore $ \st -> setSndQueueStatus st sq Confirmed
@@ -670,9 +686,27 @@ confirmQueue c connId sq SMPConfirmation {senderKey, e2ePubKey, connInfo} e2eEnc
mkConfirmation :: m MsgBody
mkConfirmation = do
encConnInfo <- agentRatchetEncrypt connId (smpEncode $ AgentConnInfo connInfo) e2eEncConnInfoLength
let agentEnvelope = AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
agentCbEncrypt sq (Just e2ePubKey) . smpEncode $
SMP.ClientMessage (SMP.PHConfirmation senderKey) $ smpEncode agentEnvelope
pure . smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
enqueueConfirmation :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c connId sq connInfo e2eEncryption = do
resumeMsgDelivery c connId sq
msgId <- storeConfirmation
queuePendingMsgs c connId sq [msgId]
where
storeConfirmation :: m InternalId
storeConfirmation = do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- withStore (`updateSndIds` connId)
let agentMsg = AgentConnInfo connInfo
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
encConnInfo <- agentRatchetEncrypt connId agentMsgStr e2eEncConnInfoLength
let msgBody = smpEncode $ AgentConfirmation {agentVersion = smpAgentVersion, e2eEncryption, encConnInfo}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgBody, internalHash, prevMsgHash}
withStore $ \st -> createSndMsg st connId msgData
pure internalId
-- encoded AgentMessage -> encoded EncAgentMessage
agentRatchetEncrypt :: AgentMonad m => ConnId -> ByteString -> Int -> m ByteString
@@ -694,27 +728,27 @@ agentRatchetDecrypt connId encAgentMsg = do
notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> ConnInfo -> m (SndQueue, SMPConfirmation)
newSndQueue qInfo cInfo =
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => Compatible SMPQueueInfo -> m SndQueue
newSndQueue qInfo =
asks (cmdSignAlg . config) >>= \case
C.SignAlg a -> newSndQueue_ a qInfo cInfo
C.SignAlg a -> newSndQueue_ a qInfo
newSndQueue_ ::
(C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m) =>
C.SAlgorithm a ->
Compatible SMPQueueInfo ->
ConnInfo ->
m (SndQueue, SMPConfirmation)
newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) cInfo = do
m SndQueue
newSndQueue_ a (Compatible (SMPQueueInfo _clientVersion smpServer senderId rcvE2ePubDhKey)) = do
-- this function assumes clientVersion is compatible - it was tested before
(senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
(sndPublicKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
(e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
let sndQueue =
SndQueue
{ server = smpServer,
sndId = senderId,
sndPrivateKey,
e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
status = New
}
pure (sndQueue, SMPConfirmation senderKey e2ePubKey cInfo)
pure
SndQueue
{ server = smpServer,
sndId = senderId,
sndPublicKey = Just sndPublicKey,
sndPrivateKey,
e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
e2ePubKey = Just e2ePubKey,
status = New
}
+98 -44
View File
@@ -37,7 +37,7 @@ module Simplex.Messaging.Agent.Client
where
import Control.Concurrent (forkIO)
import Control.Concurrent.Async (Async, async, uninterruptibleCancel)
import Control.Concurrent.Async (Async, uninterruptibleCancel)
import Control.Concurrent.STM (stateTVar)
import Control.Logger.Simple
import Control.Monad.Except
@@ -47,6 +47,7 @@ import Data.Bifunctor (first)
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (isNothing)
@@ -62,8 +63,10 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol (QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Util (bshow, liftEitherError, liftError, liftIOEither, tryError)
import Simplex.Messaging.Util (bshow, liftEitherError, liftError, tryError)
import Simplex.Messaging.Version
import System.Timeout (timeout)
import UnliftIO (async)
import UnliftIO.Exception (Exception, IOException)
import qualified UnliftIO.Exception as E
import UnliftIO.STM
@@ -74,13 +77,16 @@ data AgentClient = AgentClient
{ rcvQ :: TBQueue (ATransmission 'Client),
subQ :: TBQueue (ATransmission 'Agent),
msgQ :: TBQueue SMPServerTransmission,
smpServers :: TVar (NonEmpty SMPServer),
smpClients :: TVar (Map SMPServer SMPClientVar),
subscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
pendingSubscrSrvrs :: TVar (Map SMPServer (Map ConnId RcvQueue)),
subscrConns :: TVar (Map ConnId SMPServer),
connMsgsQueued :: TVar (Map ConnId Bool),
smpQueueMsgQueues :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (TQueue InternalId)),
smpQueueMsgDeliveries :: TVar (Map (ConnId, SMPServer, SMP.SenderId) (Async ())),
reconnections :: TVar [Async ()],
asyncClients :: TVar [Async ()],
clientId :: Int,
agentEnv :: Env,
smpSubscriber :: Async (),
@@ -93,16 +99,19 @@ newAgentClient agentEnv = do
rcvQ <- newTBQueue qSize
subQ <- newTBQueue qSize
msgQ <- newTBQueue qSize
smpServers <- newTVar $ initialSMPServers (config agentEnv)
smpClients <- newTVar M.empty
subscrSrvrs <- newTVar M.empty
pendingSubscrSrvrs <- newTVar M.empty
subscrConns <- newTVar M.empty
connMsgsQueued <- newTVar M.empty
smpQueueMsgQueues <- newTVar M.empty
smpQueueMsgDeliveries <- newTVar M.empty
reconnections <- newTVar []
asyncClients <- newTVar []
clientId <- stateTVar (clientCounter agentEnv) $ \i -> (i + 1, i + 1)
lock <- newTMVar ()
return AgentClient {rcvQ, subQ, msgQ, smpClients, subscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, clientId, agentEnv, smpSubscriber = undefined, lock}
return AgentClient {rcvQ, subQ, msgQ, smpServers, smpClients, subscrSrvrs, pendingSubscrSrvrs, subscrConns, connMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, reconnections, asyncClients, clientId, agentEnv, smpSubscriber = undefined, lock}
-- | Agent monad with MonadReader Env and MonadError AgentErrorType
type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
@@ -133,20 +142,39 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
pure smpVar
waitForSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
waitForSMPClient = liftIOEither . atomically . readTMVar
waitForSMPClient smpVar = do
SMPClientConfig {tcpTimeout} <- asks $ smpCfg . config
smpClient_ <- liftIO $ tcpTimeout `timeout` atomically (readTMVar smpVar)
liftEither $ case smpClient_ of
Just (Right smpClient) -> Right smpClient
Just (Left e) -> Left e
Nothing -> Left $ BROKER TIMEOUT
newSMPClient :: TMVar (Either AgentErrorType SMPClient) -> m SMPClient
newSMPClient smpVar =
tryError connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
pure smp
Left e -> do
atomically $ do
putTMVar smpVar r
modifyTVar smpClients $ M.delete srv
throwError e
newSMPClient smpVar = tryConnectClient pure tryConnectAsync
where
tryConnectClient :: (SMPClient -> m a) -> m () -> m a
tryConnectClient successAction retryAction =
tryError connectClient >>= \r -> case r of
Right smp -> do
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv
atomically $ putTMVar smpVar r
successAction smp
Left e -> do
if e == BROKER NETWORK || e == BROKER TIMEOUT
then retryAction
else atomically $ do
putTMVar smpVar (Left e)
modifyTVar smpClients $ M.delete srv
throwError e
tryConnectAsync :: m ()
tryConnectAsync = do
a <- async connectAsync
atomically $ modifyTVar (asyncClients c) (a :)
connectAsync :: m ()
connectAsync = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop -> void $ tryConnectClient (const reconnectClient) loop
connectClient :: m SMPClient
connectClient = do
@@ -169,33 +197,43 @@ getSMPServerClient c@AgentClient {smpClients, msgQ} srv =
cs <- M.lookup srv <$> readTVar (subscrSrvrs c)
modifyTVar (subscrSrvrs c) $ M.delete srv
modifyTVar (subscrConns c) $ maybe id (deleteKeys . M.keysSet) cs
mapM_ (modifyTVar (pendingSubscrSrvrs c) . addPendingSubs) cs
return cs
where
addPendingSubs :: Map ConnId RcvQueue -> Map SMPServer (Map ConnId RcvQueue) -> Map SMPServer (Map ConnId RcvQueue)
addPendingSubs cs = M.alter (Just . addSubs cs) srv
addSubs cs = maybe cs (M.union cs)
deleteKeys :: Ord k => Set k -> Map k a -> Map k a
deleteKeys ks m = S.foldr' M.delete m ks
serverDown :: UnliftIO m -> Map ConnId RcvQueue -> IO ()
serverDown u cs = unless (M.null cs) $ do
mapM_ (notifySub DOWN) $ M.keysSet cs
a <- async . unliftIO u $ tryReconnectClient cs
unliftIO u reconnectServer
reconnectServer :: m ()
reconnectServer = do
a <- async tryReconnectClient
atomically $ modifyTVar (reconnections c) (a :)
tryReconnectClient :: Map ConnId RcvQueue -> m ()
tryReconnectClient cs = do
tryReconnectClient :: m ()
tryReconnectClient = do
ri <- asks $ reconnectInterval . config
withRetryInterval ri $ \loop ->
reconnectClient cs `catchError` const loop
reconnectClient `catchError` const loop
reconnectClient :: Map ConnId RcvQueue -> m ()
reconnectClient cs = do
reconnectClient :: m ()
reconnectClient = do
withAgentLock c . withSMP c srv $ \smp -> do
subs <- readTVarIO $ subscrConns c
forM_ (M.toList cs) $ \(connId, rq@RcvQueue {rcvPrivateKey, rcvId}) ->
cs <- M.lookup srv <$> readTVarIO (pendingSubscrSrvrs c)
forM_ (maybe [] M.toList cs) $ \(connId, rq@RcvQueue {rcvPrivateKey, rcvId}) ->
when (isNothing $ M.lookup connId subs) $ do
subscribeSMPQueue smp rcvPrivateKey rcvId
`catchError` \case
SMPServerError e -> liftIO $ notifySub (ERR $ SMP e) connId
e -> throwError e
e@SMPResponseTimeout -> throwError e
e@SMPNetworkError -> throwError e
e -> liftIO $ notifySub (ERR $ smpClientError e) connId
addSubscription c rq connId
liftIO $ notifySub UP connId
@@ -206,6 +244,7 @@ closeAgentClient :: MonadUnliftIO m => AgentClient -> m ()
closeAgentClient c = liftIO $ do
closeSMPServerClients c
cancelActions $ reconnections c
cancelActions $ asyncClients c
cancelActions $ smpQueueMsgDeliveries c
closeSMPServerClients :: AgentClient -> IO ()
@@ -294,26 +333,40 @@ newRcvQueue_ a c srv = do
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
withLogSMP c server rcvId "SUB" $ \smp ->
subscribeSMPQueue smp rcvPrivateKey rcvId
addSubscription c rq connId
addPendingSubscription c rq connId
withLogSMP c server rcvId "SUB" $ \smp -> do
liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
Left e -> do
atomically . when (e /= SMPNetworkError && e /= SMPResponseTimeout) $
removePendingSubscription c server connId
throwError e
Right _ -> addSubscription c rq connId
addSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addSubscription c rq@RcvQueue {server} connId = atomically $ do
modifyTVar (subscrConns c) $ M.insert connId server
modifyTVar (subscrSrvrs c) $ M.alter (Just . addSub) server
where
addSub :: Maybe (Map ConnId RcvQueue) -> Map ConnId RcvQueue
addSub (Just cs) = M.insert connId rq cs
addSub _ = M.singleton connId rq
addSubs_ (subscrSrvrs c) rq connId
removePendingSubscription c server connId
removeSubscription :: AgentMonad m => AgentClient -> ConnId -> m ()
removeSubscription AgentClient {subscrConns, subscrSrvrs} connId = atomically $ do
cs <- readTVar subscrConns
writeTVar subscrConns $ M.delete connId cs
mapM_
(modifyTVar subscrSrvrs . M.alter (>>= delSub))
(M.lookup connId cs)
addPendingSubscription :: MonadUnliftIO m => AgentClient -> RcvQueue -> ConnId -> m ()
addPendingSubscription c rq connId =
atomically $ addSubs_ (pendingSubscrSrvrs c) rq connId
addSubs_ :: TVar (Map SMPServer (Map ConnId RcvQueue)) -> RcvQueue -> ConnId -> STM ()
addSubs_ ss rq@RcvQueue {server} connId = modifyTVar ss $ M.alter (Just . addSub) server
where
addSub = maybe (M.singleton connId rq) (M.insert connId rq)
removeSubscription :: MonadUnliftIO m => AgentClient -> ConnId -> m ()
removeSubscription c@AgentClient {subscrConns} connId = atomically $ do
server_ <- stateTVar subscrConns $ \cs -> (M.lookup connId cs, M.delete connId cs)
mapM_ (\server -> removeSubs_ (subscrSrvrs c) server connId) server_
removePendingSubscription :: AgentClient -> SMPServer -> ConnId -> STM ()
removePendingSubscription c = removeSubs_ (pendingSubscrSrvrs c)
removeSubs_ :: TVar (Map SMPServer (Map ConnId RcvQueue)) -> SMPServer -> ConnId -> STM ()
removeSubs_ ss server connId = modifyTVar ss $ M.update delSub server
where
delSub :: Map ConnId RcvQueue -> Maybe (Map ConnId RcvQueue)
delSub cs =
@@ -331,11 +384,13 @@ showServer SMPServer {host, port} =
logSecret :: ByteString -> ByteString
logSecret bs = encode $ B.take 3 bs
-- TODO maybe package E2ERatchetParams into SMPConfirmation
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendConfirmation c SndQueue {server, sndId} encConfirmation =
withLogSMP_ c server sndId "SEND <CONF>" $ \smp ->
liftSMP $ sendSMPMessage smp Nothing sndId encConfirmation
sendConfirmation c sq@SndQueue {server, sndId, sndPublicKey = Just sndPublicKey, e2ePubKey = e2ePubKey@Just {}} agentConfirmation =
withLogSMP_ c server sndId "SEND <CONF>" $ \smp -> do
let clientMsg = SMP.ClientMessage (SMP.PHConfirmation sndPublicKey) agentConfirmation
msg <- agentCbEncrypt sq e2ePubKey $ smpEncode clientMsg
liftSMP $ sendSMPMessage smp Nothing sndId msg
sendConfirmation _ _ _ = throwError $ INTERNAL "sendConfirmation called without snd_queue public key(s) in the database"
sendInvitation :: forall m. AgentMonad m => AgentClient -> Compatible SMPQueueInfo -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> m ()
sendInvitation c (Compatible SMPQueueInfo {smpServer, senderId, dhPublicKey}) connReq connInfo =
@@ -370,7 +425,6 @@ deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
withLogSMP c server rcvId "DEL" $ \smp ->
deleteSMPQueue smp rcvPrivateKey rcvId
-- TODO this is just wrong
sendAgentMessage :: forall m. AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} agentMsg =
withLogSMP_ c server sndId "SEND <MSG>" $ \smp -> do
+9 -7
View File
@@ -29,12 +29,13 @@ import UnliftIO.STM
data AgentConfig = AgentConfig
{ tcpPort :: ServiceName,
smpServers :: NonEmpty SMPServer,
initialSMPServers :: NonEmpty SMPServer,
cmdSignAlg :: C.SignAlg,
connIdBytes :: Int,
tbqSize :: Natural,
dbFile :: FilePath,
dbPoolSize :: Int,
yesToMigrations :: Bool,
smpCfg :: SMPClientConfig,
reconnectInterval :: RetryInterval,
helloTimeout :: NominalDiffTime,
@@ -47,12 +48,13 @@ defaultAgentConfig :: AgentConfig
defaultAgentConfig =
AgentConfig
{ tcpPort = "5224",
smpServers = undefined, -- TODO move it elsewhere?
initialSMPServers = undefined, -- TODO move it elsewhere?
cmdSignAlg = C.SignAlg C.SEd448,
connIdBytes = 12,
tbqSize = 16,
tbqSize = 64,
dbFile = "smp-agent.db",
dbPoolSize = 4,
yesToMigrations = False,
smpCfg = smpDefaultConfig,
reconnectInterval =
RetryInterval
@@ -60,7 +62,7 @@ defaultAgentConfig =
increaseAfter = 10 * second,
maxInterval = 10 * second
},
helloTimeout = 7 * nominalDay,
helloTimeout = 2 * nominalDay,
-- CA certificate private key is not needed for initialization
-- ! we do not generate these
caCertificateFile = "/etc/opt/simplex-agent/ca.crt",
@@ -79,9 +81,9 @@ data Env = Env
}
newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env
newSMPAgentEnv cfg = do
newSMPAgentEnv config@AgentConfig {dbFile, dbPoolSize, yesToMigrations} = do
idsDrg <- newTVarIO =<< drgNew
store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
store <- liftIO $ createSQLiteStore dbFile dbPoolSize Migrations.app yesToMigrations
clientCounter <- newTVarIO 0
randomServer <- newTVarIO =<< liftIO newStdGen
return Env {config = cfg, store, idsDrg, clientCounter, randomServer}
return Env {config, store, idsDrg, clientCounter, randomServer}
+28 -9
View File
@@ -46,9 +46,9 @@ module Simplex.Messaging.Agent.Protocol
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
AgentMessageType (..),
APrivHeader (..),
AMessage (..),
AMsgType (..),
SMPServer (..),
SrvLoc (..),
SMPQueueUri (..),
@@ -89,7 +89,7 @@ module Simplex.Messaging.Agent.Protocol
connModeT,
serializeQueueStatus,
queueStatusT,
aMessageType,
agentMessageType,
-- * TCP transport functions
tPut,
@@ -343,6 +343,31 @@ instance Encoding AgentMessage where
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
data AgentMessageType = AM_CONN_INFO | AM_HELLO_ | AM_REPLY_ | AM_A_MSG_
deriving (Eq, Show)
instance Encoding AgentMessageType where
smpEncode = \case
AM_CONN_INFO -> "C"
AM_HELLO_ -> "H"
AM_REPLY_ -> "R"
AM_A_MSG_ -> "M"
smpP =
A.anyChar >>= \case
'C' -> pure AM_CONN_INFO
'H' -> pure AM_HELLO_
'R' -> pure AM_REPLY_
'M' -> pure AM_A_MSG_
_ -> fail "bad AgentMessageType"
agentMessageType :: AgentMessage -> AgentMessageType
agentMessageType = \case
AgentConnInfo _ -> AM_CONN_INFO
AgentMessage _ aMsg -> case aMsg of
HELLO -> AM_HELLO_
REPLY _ -> AM_REPLY_
A_MSG _ -> AM_A_MSG_
data APrivHeader = APrivHeader
{ -- | sequential ID assigned by the sending agent
sndMsgId :: AgentMsgId,
@@ -371,12 +396,6 @@ instance Encoding AMsgType where
'M' -> pure A_MSG_
_ -> fail "bad AMsgType"
aMessageType :: AMessage -> AMsgType
aMessageType = \case
HELLO -> HELLO_
REPLY _ -> REPLY_
A_MSG _ -> A_MSG_
-- | Messages sent between SMP agents once SMP queue is secured.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents
@@ -705,7 +724,7 @@ data ConnectionErrorType
SIMPLEX
| -- | connection not accepted on join HELLO after timeout
NOT_ACCEPTED
| -- | connection not available on reply HELLO after timeout
| -- | connection not available on reply confirmation/HELLO after timeout
NOT_AVAILABLE
deriving (Eq, Generic, Read, Show, Exception)
+7 -4
View File
@@ -62,7 +62,7 @@ class Monad m => MonadAgentStore s m where
createRcvMsg :: s -> ConnId -> RcvMsgData -> m ()
updateSndIds :: s -> ConnId -> m (InternalId, InternalSndId, PrevSndMsgHash)
createSndMsg :: s -> ConnId -> SndMsgData -> m ()
getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
getPendingMsgData :: s -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
getPendingMsgs :: s -> ConnId -> m [InternalId]
checkRcvMsg :: s -> ConnId -> InternalId -> m ()
deleteMsg :: s -> ConnId -> InternalId -> m ()
@@ -102,8 +102,11 @@ data SndQueue = SndQueue
{ server :: SMPServer,
-- | sender queue ID
sndId :: SMP.SenderId,
-- | key used by the sender to sign transmissions
-- | key pair used by the sender to sign transmissions
sndPublicKey :: Maybe C.APublicVerifyKey,
sndPrivateKey :: SndPrivateSignKey,
-- | DH public key used to negotiate per-queue e2e encryption
e2ePubKey :: Maybe C.PublicKeyX25519,
-- | shared DH secret agreed for simple per-queue e2e encryption
e2eDhSecret :: C.DhSecretX25519,
-- | queue status
@@ -221,7 +224,7 @@ type PrevSndMsgHash = MsgHash
data RcvMsgData = RcvMsgData
{ msgMeta :: MsgMeta,
msgType :: AMsgType,
msgType :: AgentMessageType,
msgBody :: MsgBody,
internalRcvId :: InternalRcvId,
internalHash :: MsgHash,
@@ -232,7 +235,7 @@ data SndMsgData = SndMsgData
{ internalId :: InternalId,
internalSndId :: InternalSndId,
internalTs :: InternalTs,
msgType :: AMsgType,
msgType :: AgentMessageType,
msgBody :: MsgBody,
internalHash :: MsgHash,
prevMsgHash :: MsgHash
+19 -39
View File
@@ -76,13 +76,13 @@ data SQLiteStore = SQLiteStore
dbNew :: Bool
}
createSQLiteStore :: FilePath -> Int -> [Migration] -> IO SQLiteStore
createSQLiteStore dbFilePath poolSize migrations = do
createSQLiteStore :: FilePath -> Int -> [Migration] -> Bool -> IO SQLiteStore
createSQLiteStore dbFilePath poolSize migrations yesToMigrations = do
let dbDir = takeDirectory dbFilePath
createDirectoryIfMissing False dbDir
st <- connectSQLiteStore dbFilePath poolSize
checkThreadsafe st
migrateSchema st migrations
migrateSchema st migrations yesToMigrations
pure st
checkThreadsafe :: SQLiteStore -> IO ()
@@ -94,15 +94,16 @@ checkThreadsafe st = withConnection st $ \db -> do
Nothing -> putStrLn "Warning: SQLite THREADSAFE compile option not found"
_ -> return ()
migrateSchema :: SQLiteStore -> [Migration] -> IO ()
migrateSchema st migrations = withConnection st $ \db -> do
migrateSchema :: SQLiteStore -> [Migration] -> Bool -> IO ()
migrateSchema st migrations yesToMigrations = withConnection st $ \db -> do
Migrations.initialize db
Migrations.get db migrations >>= \case
Left e -> confirmOrExit $ "Database error: " <> e
Right [] -> pure ()
Right ms -> do
unless (dbNew st) $ do
confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
unless yesToMigrations $
confirmOrExit "The app has a newer version than the database - it will be backed up and upgraded."
let f = dbFilePath st
copyFile f (f <> ".bak")
Migrations.run db ms
@@ -440,7 +441,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
insertSndMsgDetails_ db connId sndMsgData
updateHashSnd_ db connId sndMsgData
getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AMsgType, MsgBody, InternalTs))
getPendingMsgData :: SQLiteStore -> ConnId -> InternalId -> m (Maybe RcvQueue, (AgentMessageType, MsgBody, InternalTs))
getPendingMsgData st connId msgId =
liftIOEither . withTransaction st $ \db -> runExceptT $ do
rq_ <- liftIO $ getRcvQueueByConnId_ db connId
@@ -565,9 +566,9 @@ instance ToField InternalId where toField (InternalId x) = toField x
instance FromField InternalId where fromField x = InternalId <$> fromField x
instance ToField AMsgType where toField = toField . smpEncode
instance ToField AgentMessageType where toField = toField . smpEncode
instance FromField AMsgType where fromField = blobFieldParser smpP
instance FromField AgentMessageType where fromField = blobFieldParser smpP
instance ToField MsgIntegrity where toField = toField . strEncode
@@ -655,46 +656,25 @@ upsertServer_ dbConn SMPServer {host, port, keyHash} = do
insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
insertRcvQueue_ dbConn connId RcvQueue {..} = do
DB.executeNamed
DB.execute
dbConn
[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, status)
VALUES
(:host,:port,:rcv_id,:conn_id,:rcv_private_key,:rcv_dh_secret,:e2e_priv_key,:e2e_dh_secret,:snd_id,:status);
( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, status) VALUES (?,?,?,?,?,?,?,?,?,?);
|]
[ ":host" := host server,
":port" := port server,
":rcv_id" := rcvId,
":conn_id" := connId,
":rcv_private_key" := rcvPrivateKey,
":rcv_dh_secret" := rcvDhSecret,
":e2e_priv_key" := e2ePrivKey,
":e2e_dh_secret" := e2eDhSecret,
":snd_id" := sndId,
":status" := status
]
(host server, port server, rcvId, connId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status)
-- * createSndConn helpers
insertSndQueue_ :: DB.Connection -> ConnId -> SndQueue -> IO ()
insertSndQueue_ dbConn connId SndQueue {..} = do
DB.executeNamed
DB.execute
dbConn
[sql|
INSERT INTO snd_queues
( host, port, snd_id, conn_id, snd_private_key, e2e_dh_secret, status)
VALUES
(:host,:port,:snd_id,:conn_id,:snd_private_key,:e2e_dh_secret,:status);
(host, port, snd_id, conn_id, snd_public_key, snd_private_key, e2e_pub_key, e2e_dh_secret, status) VALUES (?,?,?,?,?, ?,?, ?,?);
|]
[ ":host" := host server,
":port" := port server,
":snd_id" := sndId,
":conn_id" := connId,
":snd_private_key" := sndPrivateKey,
":e2e_dh_secret" := e2eDhSecret,
":status" := status
]
(host server, port server, sndId, connId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)
-- * getConn helpers
@@ -745,16 +725,16 @@ getSndQueueByConnId_ dbConn connId =
<$> DB.query
dbConn
[sql|
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.e2e_dh_secret, q.status
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_public_key, q.snd_private_key, q.e2e_pub_key, q.e2e_dh_secret, q.status
FROM snd_queues q
INNER JOIN servers s ON q.host = s.host AND q.port = s.port
WHERE q.conn_id = ?;
|]
(Only connId)
where
sndQueue [(keyHash, host, port, sndId, sndPrivateKey, e2eDhSecret, status)] =
sndQueue [(keyHash, host, port, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
let server = SMPServer host port keyHash
in Just SndQueue {server, sndId, sndPrivateKey, e2eDhSecret, status}
in Just SndQueue {server, sndId, sndPublicKey, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
sndQueue _ = Nothing
-- * updateRcvIds helpers
@@ -25,13 +25,17 @@ import qualified Database.SQLite.Simple as DB
import Database.SQLite.Simple.QQ (sql)
import qualified Database.SQLite3 as SQLite3
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220101_initial
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220320_server_ips
data Migration = Migration {name :: String, up :: Text}
deriving (Show)
schemaMigrations :: [(String, Query)]
schemaMigrations =
[ ("20220101_initial", m20220101_initial)
[ ("20220101_initial", m20220101_initial),
("20220301_snd_queue_keys", m20220301_snd_queue_keys),
("20220320_server_ips", m20220320_server_ips)
]
-- | The list of migrations in ascending order by date
@@ -0,0 +1,13 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220301_snd_queue_keys where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220301_snd_queue_keys :: Query
m20220301_snd_queue_keys =
[sql|
ALTER TABLE snd_queues ADD COLUMN snd_public_key BLOB;
ALTER TABLE snd_queues ADD COLUMN e2e_pub_key BLOB;
|]
@@ -0,0 +1,14 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20220320_server_ips where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220320_server_ips :: Query
m20220320_server_ips =
[sql|
UPDATE servers SET host = '178.79.168.175' WHERE host = 'smp8.simplex.im';
UPDATE servers SET host = '178.79.169.107' WHERE host = 'smp9.simplex.im';
UPDATE servers SET host = '45.33.54.229' WHERE host = 'smp10.simplex.im';
|]
+1 -1
View File
@@ -107,7 +107,7 @@ data SMPClientConfig = SMPClientConfig
smpDefaultConfig :: SMPClientConfig
smpDefaultConfig =
SMPClientConfig
{ qSize = 16,
{ qSize = 64,
defaultTransport = ("5223", transport @TLS),
tcpTimeout = 4_000_000,
smpPing = 30_000_000
+7
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -97,13 +98,18 @@ enumJSON tagModifier =
}
sumTypeJSON :: (String -> String) -> J.Options
#if defined(darwin_HOST_OS)
sumTypeJSON = singleFieldJSON
#else
sumTypeJSON = taggedObjectJSON
#endif
taggedObjectJSON :: (String -> String) -> J.Options
taggedObjectJSON tagModifier =
J.defaultOptions
{ J.sumEncoding = J.TaggedObject "type" "data",
J.constructorTagModifier = tagModifier,
J.allNullaryToStringTag = False,
J.nullaryToObject = True,
J.omitNothingFields = True
}
@@ -113,6 +119,7 @@ singleFieldJSON tagModifier =
J.defaultOptions
{ J.sumEncoding = J.ObjectWithSingleField,
J.constructorTagModifier = tagModifier,
J.allNullaryToStringTag = False,
J.nullaryToObject = True,
J.omitNothingFields = True
}
+4
View File
@@ -399,6 +399,10 @@ instance StrEncoding SMPServer where
SrvLoc host port <- strP
pure SMPServer {host, port, keyHash}
instance ToJSON SMPServer where
toJSON = strToJSON
toEncoding = strToJEncoding
data SrvLoc = SrvLoc HostName ServiceName
deriving (Eq, Ord, Show)
+1 -1
View File
@@ -96,7 +96,7 @@ supportedSMPVersions :: VersionRange
supportedSMPVersions = mkVersionRange 1 1
simplexMQVersion :: String
simplexMQVersion = "1.0.2"
simplexMQVersion = "1.0.3"
-- * Transport connection class
+1 -1
View File
@@ -75,7 +75,7 @@ validateCertificateChain (C.KeyHash kh) host port cc@(X.CertificateChain sc@[_,
x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
where
hooks = XV.defaultHooks
checks = XV.defaultChecks
checks = XV.defaultChecks {XV.checkFQHN = False}
certStore = XS.makeCertificateStore sc
cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the identity certificate (ca.crt)
serviceID = (host, port)
+104 -65
View File
@@ -62,9 +62,11 @@ agentTests (ATransport t) = do
smpAgentTest3_1_1 $ testSubscription t
it "should send notifications to client when server disconnects" $
smpAgentServerTest $ testSubscrNotification t
describe "Message delivery" $ do
describe "Message delivery and server reconnection" $ do
it "should deliver messages after losing server connection and re-connecting" $
smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
it "should connect to the server when server goes up if it initially was down" $
smpAgentTestN [] $ testServerConnectionAfterError t
it "should deliver pending messages after agent restarting" $
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
it "should concurrently deliver messages to connections without blocking" $
@@ -126,25 +128,25 @@ testDuplexConnection _ alice bob = do
bob <# ("", "alice", CON)
alice <# ("", "bob", CON)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 5)
alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 6)
alice <# ("", "bob", SENT 6)
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 7)
bob #: ("13", "alice", "ACK 6") #> ("13", "alice", OK)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3a", "bob", "ACK 7") #> ("3a", "bob", OK)
bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 8)
bob <# ("", "alice", SENT 8)
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
alice #: ("4a", "bob", "ACK 8") #> ("4a", "bob", OK)
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 8)
bob <# ("", "alice", MERR 8 (SMP AUTH))
bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 9)
bob <# ("", "alice", MERR 9 (SMP AUTH))
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
alice #:# "nothing else should be delivered to alice"
@@ -159,25 +161,25 @@ testDuplexConnRandomIds _ alice bob = do
bob <# ("", aliceConn, INFO "alice's connInfo")
bob <# ("", aliceConn, CON)
alice <# ("", bobConn, CON)
alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 5)
alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
bob #: ("12", aliceConn, "ACK 5") #> ("12", aliceConn, OK)
alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 6)
alice <# ("", bobConn, SENT 6)
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 6)
bob <# ("", aliceConn, SENT 6)
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 7)
bob #: ("13", aliceConn, "ACK 6") #> ("13", aliceConn, OK)
bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 7)
bob <# ("", aliceConn, SENT 7)
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
alice #: ("3a", bobConn, "ACK 7") #> ("3a", bobConn, OK)
bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 8)
bob <# ("", aliceConn, SENT 8)
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
alice #: ("4a", bobConn, "ACK 8") #> ("4a", bobConn, OK)
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 8)
bob <# ("", aliceConn, MERR 8 (SMP AUTH))
bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 9)
bob <# ("", aliceConn, MERR 9 (SMP AUTH))
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
alice #:# "nothing else should be delivered to alice"
@@ -194,10 +196,10 @@ testContactConnection _ alice bob tom = do
alice <# ("", "bob", INFO "bob's connInfo 2")
alice <# ("", "bob", CON)
bob <# ("", "alice", CON)
alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 4)
alice <# ("", "bob", SENT 4)
alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
@@ -207,10 +209,10 @@ testContactConnection _ alice bob tom = do
alice <# ("", "tom", INFO "tom's connInfo 2")
alice <# ("", "tom", CON)
tom <# ("", "alice", CON)
alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 4)
alice <# ("", "tom", SENT 4)
alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 5)
alice <# ("", "tom", SENT 5)
tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
tom #: ("23", "alice", "ACK 5") #> ("23", "alice", OK)
testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
testContactConnRandomIds _ alice bob = do
@@ -230,10 +232,10 @@ testContactConnRandomIds _ alice bob = do
alice <# ("", bobConn, CON)
bob <# ("", aliceConn, CON)
alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 4)
alice <# ("", bobConn, SENT 4)
alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 5)
alice <# ("", bobConn, SENT 5)
bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
testRejectContactRequest _ alice bob = do
@@ -250,20 +252,20 @@ testRejectContactRequest _ alice bob = do
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
testSubscription _ alice1 alice2 bob = do
(alice1, "alice") `connect` (bob, "bob")
bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 4)
bob <# ("", "alice", SENT 4)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 5)
bob #: ("12", "alice", "SEND 5\nhello") #> ("12", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
alice1 #: ("1", "bob", "ACK 5") #> ("1", "bob", OK)
bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 6)
bob <# ("", "alice", SENT 6)
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
alice1 #: ("2", "bob", "ACK 6") #> ("2", "bob", OK)
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
alice1 <# ("", "bob", END)
bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 7)
bob <# ("", "alice", SENT 7)
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
alice2 #: ("22", "bob", "ACK 7") #> ("22", "bob", OK)
alice1 #:# "nothing else should be delivered to alice1"
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
@@ -279,40 +281,77 @@ testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryServerRestart t alice bob = do
withServer $ do
connect (alice, "alice") (bob, "bob")
bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 4)
bob <# ("", "alice", SENT 4)
bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 5)
bob <# ("", "alice", SENT 5)
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
alice #: ("11", "bob", "ACK 5") #> ("11", "bob", OK)
alice #:# "nothing else delivered before the server is killed"
alice <# ("", "bob", DOWN)
bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 5)
bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 6)
bob #:# "nothing else delivered before the server is restarted"
alice #:# "nothing else delivered before the server is restarted"
withServer $ do
bob <# ("", "alice", SENT 5)
bob <# ("", "alice", SENT 6)
alice <# ("", "bob", UP)
alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
alice #: ("12", "bob", "ACK 6") #> ("12", "bob", OK)
removeFile testStoreLogFile
where
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
testServerConnectionAfterError t _ = do
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
bob <# ("", "alice", DOWN)
alice <# ("", "bob", DOWN)
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
withAgent1 $ \bob -> do
withAgent2 $ \alice -> do
bob #: ("1", "alice", "SUB") #> ("1", "alice", ERR (BROKER NETWORK))
alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
withServer $ do
alice <#= \case ("", "bob", cmd) -> cmd == UP || cmd == SENT 5; _ -> False
alice <#= \case ("", "bob", cmd) -> cmd == UP || cmd == SENT 5; _ -> False
bob <# ("", "alice", UP)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
alice #: ("1", "bob", "SEND 11\nhello again") #> ("1", "bob", MID 6)
alice <# ("", "bob", SENT 6)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
removeFile testStoreLogFile
removeFile testDB
removeFile testDB2
where
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
withAgent1 = withAgent agentTestPort testDB
withAgent2 = withAgent agentTestPort2 testDB2
withAgent :: String -> String -> (c -> IO a) -> IO a
withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
testMsgDeliveryAgentRestart t bob = do
withAgent $ \alice -> do
withServer $ do
connect (bob, "bob") (alice, "alice")
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 4)
alice <# ("", "bob", SENT 4)
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 5)
alice <# ("", "bob", SENT 5)
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
bob #: ("11", "alice", "ACK 5") #> ("11", "alice", OK)
bob #:# "nothing else delivered before the server is down"
bob <# ("", "alice", DOWN)
alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 5)
alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 6)
alice #:# "nothing else delivered before the server is restarted"
bob #:# "nothing else delivered before the server is restarted"
@@ -322,11 +361,11 @@ testMsgDeliveryAgentRestart t bob = do
alice <#= \case
(corrId, "bob", cmd) ->
(corrId == "3" && cmd == OK)
|| (corrId == "" && cmd == SENT 5)
|| (corrId == "" && cmd == SENT 6)
_ -> False
bob <# ("", "alice", UP)
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
bob #: ("12", "alice", "ACK 6") #> ("12", "alice", OK)
removeFile testStoreLogFile
removeFile testDB
@@ -354,11 +393,11 @@ testConcurrentMsgDelivery _ alice bob = do
-- alice <# ("", "bob", SENT 1)
-- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
-- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 5)
bob <# ("", "alice", SENT 5)
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 6)
bob <# ("", "alice", SENT 6)
-- if delivery is blocked it won't go further
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
alice #: ("3", "bob", "ACK 6") #> ("3", "bob", OK)
testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
testMsgDeliveryQuotaExceeded _ alice bob = do
@@ -371,9 +410,9 @@ testMsgDeliveryQuotaExceeded _ alice bob = do
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 4)
alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 5)
-- if delivery is blocked it won't go further
alice <# ("", "bob2", SENT 4)
alice <# ("", "bob2", SENT 5)
connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
connect (h1, name1) (h2, name2) = do
@@ -429,7 +468,7 @@ syntaxTests t = do
"a",
"JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
<> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
<> "%40localhost%3A5001%2F3456-w%3D%3D%23"
<> "%40127.0.0.1%3A5001%2F3456-w%3D%3D%23"
<> urlEncode True sampleDhKey
<> "&v=1"
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
+46 -20
View File
@@ -10,7 +10,7 @@ module AgentTests.FunctionalAPITests (functionalAPITests) where
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.IO.Unlift
import SMPAgentClient
import SMPClient (withSmpServer)
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
import Simplex.Messaging.Agent.Protocol
@@ -44,6 +44,8 @@ functionalAPITests t = do
withSmpServer t testAsyncJoiningOfflineBeforeActivation
it "should connect with both clients going offline" $
withSmpServer t testAsyncBothOffline
it "should connect on the second attempt if server was offline" $
testAsyncServerOffline t
it "should notify after HELLO timeout" $
withSmpServer t testAsyncHelloTimeout
@@ -59,26 +61,26 @@ testAgentClient = do
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
4 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 4)
5 <- sendMessage alice bobId "how are you?"
-- message IDs 1 to 4 get assigned to control messages, so first MSG is assigned ID 5
5 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 5)
6 <- sendMessage alice bobId "how are you?"
get alice ##> ("", bobId, SENT 6)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId 4
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId 5
6 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 6)
7 <- sendMessage bob aliceId "message 1"
get bob =##> \case ("", c, Msg "how are you?") -> c == aliceId; _ -> False
ackMessage bob aliceId 6
7 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 7)
8 <- sendMessage bob aliceId "message 1"
get bob ##> ("", aliceId, SENT 8)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId 6
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId 7
get alice =##> \case ("", c, Msg "message 1") -> c == bobId; _ -> False
ackMessage alice bobId 8
suspendConnection alice bobId
8 <- sendMessage bob aliceId "message 2"
get bob ##> ("", aliceId, MERR 8 (SMP AUTH))
9 <- sendMessage bob aliceId "message 2"
get bob ##> ("", aliceId, MERR 9 (SMP AUTH))
deleteConnection alice bobId
liftIO $ noMessages alice "nothing else should be delivered to alice"
pure ()
@@ -148,6 +150,30 @@ testAsyncBothOffline = do
exchangeGreetings alice' bobId bob' aliceId
pure ()
testAsyncServerOffline :: ATransport -> IO ()
testAsyncServerOffline t = do
alice <- getSMPAgentClient cfg
bob <- getSMPAgentClient cfg {dbFile = testDB2}
-- create connection and shutdown the server
Right (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ ->
runExceptT $ createConnection alice SCMInvitation
-- connection fails
Left (BROKER NETWORK) <- runExceptT $ joinConnection bob cReq "bob's connInfo"
("", bobId1, DOWN) <- get alice
bobId1 `shouldBe` bobId
-- connection succeeds after server start
Right () <- withSmpServerStoreLogOn t testPort $ \_ -> runExceptT $ do
("", bobId2, UP) <- get alice
liftIO $ bobId2 `shouldBe` bobId
aliceId <- joinConnection bob cReq "bob's connInfo"
("", _, CONF confId "bob's connInfo") <- get alice
allowConnection alice bobId confId "alice's connInfo"
get alice ##> ("", bobId, CON)
get bob ##> ("", aliceId, INFO "alice's connInfo")
get bob ##> ("", aliceId, CON)
exchangeGreetings alice bobId bob aliceId
pure ()
testAsyncHelloTimeout :: IO ()
testAsyncHelloTimeout = do
alice <- getSMPAgentClient cfg
@@ -161,11 +187,11 @@ testAsyncHelloTimeout = do
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
exchangeGreetings alice bobId bob aliceId = do
4 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 4)
5 <- sendMessage alice bobId "hello"
get alice ##> ("", bobId, SENT 5)
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
ackMessage bob aliceId 4
5 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 5)
ackMessage bob aliceId 5
6 <- sendMessage bob aliceId "hello too"
get bob ##> ("", aliceId, SENT 6)
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
ackMessage alice bobId 5
ackMessage alice bobId 6
+7 -3
View File
@@ -51,7 +51,7 @@ createStore = do
-- Randomize DB file name to avoid SQLite IO errors supposedly caused by asynchronous
-- IO operations on multiple similarly named files; error seems to be environment specific
r <- randomIO :: IO Word32
createSQLiteStore (testDB <> show r) 4 Migrations.app
createSQLiteStore (testDB <> show r) 4 Migrations.app True
removeStore :: SQLiteStore -> IO ()
removeStore store = do
@@ -173,7 +173,9 @@ sndQueue1 =
SndQueue
{ server = SMPServer "smp.simplex.im" "5223" testKeyHash,
sndId = "3456",
sndPublicKey = Nothing,
sndPrivateKey = testPrivateSignKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
status = New
}
@@ -303,7 +305,9 @@ testUpgradeRcvConnToDuplex =
SndQueue
{ server = SMPServer "smp.simplex.im" "5223" testKeyHash,
sndId = "2345",
sndPublicKey = Nothing,
sndPrivateKey = testPrivateSignKey,
e2ePubKey = Nothing,
e2eDhSecret = testDhSecret,
status = New
}
@@ -393,7 +397,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
sndMsgId = externalSndId,
broker = (brokerId, ts)
},
msgType = A_MSG_,
msgType = AM_A_MSG_,
msgBody = hw,
internalHash,
externalPrevSndHash = "hash_from_sender"
@@ -422,7 +426,7 @@ mkSndMsgData internalId internalSndId internalHash =
{ internalId,
internalSndId,
internalTs = ts,
msgType = A_MSG_,
msgType = AM_A_MSG_,
msgBody = hw,
internalHash,
prevMsgHash = internalHash
+2 -2
View File
@@ -157,7 +157,7 @@ cfg :: AgentConfig
cfg =
defaultAgentConfig
{ tcpPort = agentTestPort,
smpServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
initialSMPServers = L.fromList ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5001"],
tbqSize = 1,
dbFile = testDB,
smpCfg =
@@ -174,7 +174,7 @@ cfg =
withSmpAgentThreadOn_ :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, String) -> m () -> (ThreadId -> m a) -> m a
withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess =
let cfg' = cfg {tcpPort = port', dbFile = db', smpServers = L.fromList [SMPServer "localhost" smpPort' testKeyHash]}
let cfg' = cfg {tcpPort = port', dbFile = db', initialSMPServers = L.fromList [SMPServer "127.0.0.1" smpPort' testKeyHash]}
in serverBracket
(\started -> runSMPAgentBlocking t started cfg')
afterProcess
+1 -1
View File
@@ -29,7 +29,7 @@ import UnliftIO.STM (TMVar, atomically, newEmptyTMVarIO, takeTMVar)
import UnliftIO.Timeout (timeout)
testHost :: HostName
testHost = "localhost"
testHost = "127.0.0.1"
testPort :: ServiceName
testPort = "5001"