SMP protocol v4: batching multiple server commands/responses in a transport block (#470)
* batch server commands in one transport block * subscribe to multiple queues using batched commands * agent method to subscribe to multiple queues using batched commands * refactor * test for batched subscriptions * delete part of connections in batched test * add resubscribeConnections * remove comment * update SMP protocol doc
This commit is contained in:
parent
1670c9c05e
commit
a6f401041a
|
@ -51,6 +51,8 @@ It's designed with the focus on communication security and integrity, under the
|
||||||
|
|
||||||
It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
|
It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
|
||||||
|
|
||||||
|
This document describes SMP protocol versions 3 and 4, the previous versions are discontinued.
|
||||||
|
|
||||||
## Introduction
|
## Introduction
|
||||||
|
|
||||||
The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
|
The objective of Simplex Messaging Protocol (SMP) is to facilitate the secure and private unidirectional transfer of messages from senders to recipients via persistent simplex queues managed by the message broker (server).
|
||||||
|
@ -362,15 +364,16 @@ The clients can optionally instruct a dedicated push notification server to subs
|
||||||
|
|
||||||
[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
|
[`SEND` command](#send-message) includes the notification flag to instruct SMP server whether to send the notification - this flag is forwarded to the recepient inside encrypted envelope, together with the timestamp and the message body, so even if TLS is compromised this flag cannot be used for traffic correlation.
|
||||||
|
|
||||||
## SMP Transmission structure
|
## SMP Transmission andtransport block structure
|
||||||
|
|
||||||
Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
|
Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
|
||||||
|
|
||||||
|
From SMP version 4 each block can contain multiple transmissions, version 3 blocks have 1 transmission.
|
||||||
Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
|
Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
|
||||||
|
|
||||||
In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
|
In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
|
||||||
|
|
||||||
```
|
```abnf
|
||||||
paddedString = originalLength string pad
|
paddedString = originalLength string pad
|
||||||
originalLength = 2*2 OCTET
|
originalLength = 2*2 OCTET
|
||||||
pad = N*N"#" ; where N = paddedLength - originalLength - 2
|
pad = N*N"#" ; where N = paddedLength - originalLength - 2
|
||||||
|
@ -380,9 +383,9 @@ paddedNotation = <padded(string, paddedLength)>
|
||||||
; paddedLength - required length after padding, including 2 bytes for originalLength
|
; paddedLength - required length after padding, including 2 bytes for originalLength
|
||||||
```
|
```
|
||||||
|
|
||||||
Each transmission between the client and the server must have this format/syntax:
|
Each transmission/block for SMP v3 between the client and the server must have this format/syntax:
|
||||||
|
|
||||||
```
|
```abnf
|
||||||
paddedTransmission = <padded(transmission), 16384>
|
paddedTransmission = <padded(transmission), 16384>
|
||||||
transmission = [signature] SP signed
|
transmission = [signature] SP signed
|
||||||
signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
|
signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
|
||||||
|
@ -399,6 +402,16 @@ encoded = <base64 encoded binary>
|
||||||
|
|
||||||
`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
|
`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
|
||||||
|
|
||||||
|
Transport block for SMP v4 has this syntax:
|
||||||
|
|
||||||
|
```abnf
|
||||||
|
paddedTransportBlock = <padded(transportBlock), 16384>
|
||||||
|
transportBlock = transmissionCount transmissions
|
||||||
|
transmissionCount = 1*1 OCTET ; equal or greater than 1
|
||||||
|
transmissions = transmissionLength transmission [transmissions]
|
||||||
|
transmissionLength = 2*2 OCTET ; word16 encoded in network byte order
|
||||||
|
```
|
||||||
|
|
||||||
## SMP commands
|
## SMP commands
|
||||||
|
|
||||||
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
|
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
|
||||||
|
|
|
@ -45,9 +45,11 @@ module Simplex.Messaging.Agent
|
||||||
acceptContact,
|
acceptContact,
|
||||||
rejectContact,
|
rejectContact,
|
||||||
subscribeConnection,
|
subscribeConnection,
|
||||||
|
subscribeConnections,
|
||||||
getConnectionMessage,
|
getConnectionMessage,
|
||||||
getNotificationMessage,
|
getNotificationMessage,
|
||||||
resubscribeConnection,
|
resubscribeConnection,
|
||||||
|
resubscribeConnections,
|
||||||
sendMessage,
|
sendMessage,
|
||||||
ackMessage,
|
ackMessage,
|
||||||
suspendConnection,
|
suspendConnection,
|
||||||
|
@ -79,6 +81,7 @@ import Data.Composition ((.:), (.:.))
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.List.NonEmpty (NonEmpty (..))
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
import qualified Data.List.NonEmpty as L
|
import qualified Data.List.NonEmpty as L
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe (isJust)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
@ -105,10 +108,10 @@ import Simplex.Messaging.Parsers (parse)
|
||||||
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta)
|
import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta)
|
||||||
import qualified Simplex.Messaging.Protocol as SMP
|
import qualified Simplex.Messaging.Protocol as SMP
|
||||||
import qualified Simplex.Messaging.TMap as TM
|
import qualified Simplex.Messaging.TMap as TM
|
||||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, liftE, liftError, tryError, unlessM, whenM, ($>>=))
|
import Simplex.Messaging.Util
|
||||||
import Simplex.Messaging.Version
|
import Simplex.Messaging.Version
|
||||||
import System.Random (randomR)
|
import System.Random (randomR)
|
||||||
import UnliftIO.Async (async, race_)
|
import UnliftIO.Async (async, mapConcurrently, race_)
|
||||||
import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
|
import UnliftIO.Concurrent (forkFinally, forkIO, threadDelay)
|
||||||
import qualified UnliftIO.Exception as E
|
import qualified UnliftIO.Exception as E
|
||||||
import UnliftIO.STM
|
import UnliftIO.STM
|
||||||
|
@ -158,6 +161,10 @@ rejectContact c = withAgentEnv c .: rejectContact' c
|
||||||
subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
subscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
||||||
subscribeConnection c = withAgentEnv c . subscribeConnection' c
|
subscribeConnection c = withAgentEnv c . subscribeConnection' c
|
||||||
|
|
||||||
|
-- | Subscribe to receive connection messages from multiple connections, batching commands when possible
|
||||||
|
subscribeConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
subscribeConnections c = withAgentEnv c . subscribeConnections' c
|
||||||
|
|
||||||
-- | Get connection message (GET command)
|
-- | Get connection message (GET command)
|
||||||
getConnectionMessage :: AgentErrorMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
|
getConnectionMessage :: AgentErrorMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
|
||||||
getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
|
getConnectionMessage c = withAgentEnv c . getConnectionMessage' c
|
||||||
|
@ -169,6 +176,9 @@ getNotificationMessage c = withAgentEnv c .: getNotificationMessage' c
|
||||||
resubscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
resubscribeConnection :: AgentErrorMonad m => AgentClient -> ConnId -> m ()
|
||||||
resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
|
resubscribeConnection c = withAgentEnv c . resubscribeConnection' c
|
||||||
|
|
||||||
|
resubscribeConnections :: AgentErrorMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
resubscribeConnections c = withAgentEnv c . resubscribeConnections' c
|
||||||
|
|
||||||
-- | Send message to the connection (SEND command)
|
-- | Send message to the connection (SEND command)
|
||||||
sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
|
sendMessage :: AgentErrorMonad m => AgentClient -> ConnId -> MsgFlags -> MsgBody -> m AgentMsgId
|
||||||
sendMessage c = withAgentEnv c .:. sendMessage' c
|
sendMessage c = withAgentEnv c .:. sendMessage' c
|
||||||
|
@ -393,12 +403,62 @@ subscribeConnection' c connId =
|
||||||
ns <- asks ntfSupervisor
|
ns <- asks ntfSupervisor
|
||||||
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
|
||||||
|
|
||||||
|
subscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
subscribeConnections' _ [] = pure M.empty
|
||||||
|
subscribeConnections' c connIds = do
|
||||||
|
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn)
|
||||||
|
let (errs, cs) = M.mapEither id conns
|
||||||
|
errs' = M.map (Left . storeError) errs
|
||||||
|
(sndQs, rcvQs) = M.mapEither rcvOrSndQueue cs
|
||||||
|
sndRs = M.map (sndSubResult . fst) sndQs
|
||||||
|
srvRcvQs :: Map SMPServer (Map ConnId (RcvQueue, ConnData)) = M.foldlWithKey' addRcvQueue M.empty rcvQs
|
||||||
|
mapM_ (mapM_ (uncurry $ resumeMsgDelivery c) . sndQueue) cs
|
||||||
|
rcvRs <- mapConcurrently subscribe (M.assocs srvRcvQs)
|
||||||
|
let rs = M.unions $ errs' : sndRs : rcvRs
|
||||||
|
notifyResultError rs
|
||||||
|
pure rs
|
||||||
|
where
|
||||||
|
rcvOrSndQueue :: SomeConn -> Either (SndQueue, ConnData) (RcvQueue, ConnData)
|
||||||
|
rcvOrSndQueue = \case
|
||||||
|
SomeConn _ (DuplexConnection cData rq _) -> Right (rq, cData)
|
||||||
|
SomeConn _ (SndConnection cData sq) -> Left (sq, cData)
|
||||||
|
SomeConn _ (RcvConnection cData rq) -> Right (rq, cData)
|
||||||
|
SomeConn _ (ContactConnection cData rq) -> Right (rq, cData)
|
||||||
|
sndSubResult :: SndQueue -> Either AgentErrorType ()
|
||||||
|
sndSubResult sq = case status (sq :: SndQueue) of
|
||||||
|
Confirmed -> Right ()
|
||||||
|
Active -> Left $ CONN SIMPLEX
|
||||||
|
_ -> Left $ INTERNAL "unexpected queue status"
|
||||||
|
addRcvQueue :: Map SMPServer (Map ConnId (RcvQueue, ConnData)) -> ConnId -> (RcvQueue, ConnData) -> Map SMPServer (Map ConnId (RcvQueue, ConnData))
|
||||||
|
addRcvQueue m connId rq@(RcvQueue {server}, _) = M.alter (Just . maybe (M.singleton connId rq) (M.insert connId rq)) server m
|
||||||
|
subscribe :: (SMPServer, Map ConnId (RcvQueue, ConnData)) -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
subscribe (srv, qs) = subscribeQueues c srv (M.map fst qs)
|
||||||
|
sndQueue :: SomeConn -> Maybe (ConnData, SndQueue)
|
||||||
|
sndQueue = \case
|
||||||
|
SomeConn _ (DuplexConnection cData _ sq) -> Just (cData, sq)
|
||||||
|
SomeConn _ (SndConnection cData sq) -> Just (cData, sq)
|
||||||
|
_ -> Nothing
|
||||||
|
notifyResultError :: Map ConnId (Either AgentErrorType ()) -> m ()
|
||||||
|
notifyResultError rs = do
|
||||||
|
let actual = M.size rs
|
||||||
|
expected = length connIds
|
||||||
|
when (actual /= expected) . atomically $
|
||||||
|
writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
|
||||||
|
|
||||||
resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
|
resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m ()
|
||||||
resubscribeConnection' c connId =
|
resubscribeConnection' c connId =
|
||||||
unlessM
|
unlessM
|
||||||
(atomically $ hasActiveSubscription c connId)
|
(atomically $ hasActiveSubscription c connId)
|
||||||
(subscribeConnection' c connId)
|
(subscribeConnection' c connId)
|
||||||
|
|
||||||
|
resubscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
resubscribeConnections' _ [] = pure M.empty
|
||||||
|
resubscribeConnections' c connIds = do
|
||||||
|
let r = M.fromList . zip connIds . repeat $ Right ()
|
||||||
|
connIds' <- filterM (fmap not . atomically . hasActiveSubscription c) connIds
|
||||||
|
-- union is left-biased, so results returned by subscribeConnections' take precedence
|
||||||
|
(`M.union` r) <$> subscribeConnections' c connIds'
|
||||||
|
|
||||||
getConnectionMessage' :: AgentMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
|
getConnectionMessage' :: AgentMonad m => AgentClient -> ConnId -> m (Maybe SMPMsgMeta)
|
||||||
getConnectionMessage' c connId = do
|
getConnectionMessage' c connId = do
|
||||||
whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED
|
whenM (atomically $ hasActiveSubscription c connId) . throwError $ CMD PROHIBITED
|
||||||
|
|
|
@ -21,6 +21,7 @@ module Simplex.Messaging.Agent.Client
|
||||||
closeAgentClient,
|
closeAgentClient,
|
||||||
newRcvQueue,
|
newRcvQueue,
|
||||||
subscribeQueue,
|
subscribeQueue,
|
||||||
|
subscribeQueues,
|
||||||
getQueueMessage,
|
getQueueMessage,
|
||||||
decryptSMPMessage,
|
decryptSMPMessage,
|
||||||
addSubscription,
|
addSubscription,
|
||||||
|
@ -64,6 +65,7 @@ module Simplex.Messaging.Agent.Client
|
||||||
whenSuspending,
|
whenSuspending,
|
||||||
withStore,
|
withStore,
|
||||||
withStore',
|
withStore',
|
||||||
|
storeError,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -74,16 +76,19 @@ import Control.Logger.Simple
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (bimap, first, second)
|
||||||
import Data.ByteString.Base64
|
import Data.ByteString.Base64
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
|
import Data.Either (partitionEithers)
|
||||||
import Data.List.NonEmpty (NonEmpty)
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
|
import qualified Data.List.NonEmpty as L
|
||||||
import Data.Map.Strict (Map)
|
import Data.Map.Strict (Map)
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe (catMaybes)
|
import Data.Maybe (catMaybes)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.Text.Encoding
|
import Data.Text.Encoding
|
||||||
|
import Data.Tuple (swap)
|
||||||
import Data.Word (Word16)
|
import Data.Word (Word16)
|
||||||
import qualified Database.SQLite.Simple as DB
|
import qualified Database.SQLite.Simple as DB
|
||||||
import Simplex.Messaging.Agent.Env.SQLite
|
import Simplex.Messaging.Agent.Env.SQLite
|
||||||
|
@ -103,7 +108,7 @@ import Simplex.Messaging.Protocol (BrokerMsg, ErrorType, MsgFlags (..), MsgId, N
|
||||||
import qualified Simplex.Messaging.Protocol as SMP
|
import qualified Simplex.Messaging.Protocol as SMP
|
||||||
import Simplex.Messaging.TMap (TMap)
|
import Simplex.Messaging.TMap (TMap)
|
||||||
import qualified Simplex.Messaging.TMap as TM
|
import qualified Simplex.Messaging.TMap as TM
|
||||||
import Simplex.Messaging.Util (bshow, catchAll_, ifM, liftEitherError, liftError, tryError, unlessM, whenM)
|
import Simplex.Messaging.Util
|
||||||
import Simplex.Messaging.Version
|
import Simplex.Messaging.Version
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
import UnliftIO (async, pooledForConcurrentlyN)
|
import UnliftIO (async, pooledForConcurrentlyN)
|
||||||
|
@ -476,14 +481,42 @@ subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
|
||||||
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
|
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
|
||||||
whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
|
whenM (atomically . TM.member (server, rcvId) $ getMsgLocks c) . throwError $ CMD PROHIBITED
|
||||||
atomically $ addPendingSubscription c rq connId
|
atomically $ addPendingSubscription c rq connId
|
||||||
withLogClient c server rcvId "SUB" $ \smp -> do
|
withLogClient c server rcvId "SUB" $ \smp ->
|
||||||
liftIO (runExceptT $ subscribeSMPQueue smp rcvPrivateKey rcvId) >>= \case
|
liftIO (runExceptT (subscribeSMPQueue smp rcvPrivateKey rcvId) >>= processSubResult c rq connId)
|
||||||
Left e -> do
|
>>= either throwError pure
|
||||||
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
|
|
||||||
removePendingSubscription c server connId
|
processSubResult :: AgentClient -> RcvQueue -> ConnId -> Either ProtocolClientError () -> IO (Either ProtocolClientError ())
|
||||||
throwError e
|
processSubResult c rq@RcvQueue {server} connId r = do
|
||||||
Right _ -> do
|
case r of
|
||||||
addSubscription c rq connId
|
Left e ->
|
||||||
|
atomically . when (e /= PCENetworkError && e /= PCEResponseTimeout) $
|
||||||
|
removePendingSubscription c server connId
|
||||||
|
_ -> addSubscription c rq connId
|
||||||
|
pure r
|
||||||
|
|
||||||
|
-- | subscribe multiple queues - all passed queues should be on the same server
|
||||||
|
subscribeQueues :: AgentMonad m => AgentClient -> SMPServer -> Map ConnId RcvQueue -> m (Map ConnId (Either AgentErrorType ()))
|
||||||
|
subscribeQueues c srv qs = do
|
||||||
|
(errs, qs_) <- partitionEithers <$> mapM checkQueue (M.assocs qs)
|
||||||
|
forM_ qs_ $ atomically . uncurry (addPendingSubscription c) . swap
|
||||||
|
case L.nonEmpty qs_ of
|
||||||
|
Just qs' -> do
|
||||||
|
smp_ <- tryError (getSMPServerClient c srv)
|
||||||
|
M.fromList . (errs <>) <$> case smp_ of
|
||||||
|
Left e -> pure $ map (second . const $ Left e) qs_
|
||||||
|
Right smp -> do
|
||||||
|
logServer "-->" c srv (bshow (length qs_) <> " queues") "SUB"
|
||||||
|
let qs2 = L.map (queueCreds . snd) qs'
|
||||||
|
rs' :: [((ConnId, RcvQueue), Either ProtocolClientError ())] <-
|
||||||
|
liftIO $ zip qs_ . L.toList <$> subscribeSMPQueues smp qs2
|
||||||
|
forM_ rs' $ \((connId, rq), r) -> liftIO $ processSubResult c rq connId r
|
||||||
|
pure $ map (bimap fst (first $ protocolClientError SMP)) rs'
|
||||||
|
_ -> pure $ M.fromList errs
|
||||||
|
where
|
||||||
|
checkQueue rq@(connId, RcvQueue {rcvId, server}) = do
|
||||||
|
prohibited <- atomically . TM.member (server, rcvId) $ getMsgLocks c
|
||||||
|
pure $ if prohibited || srv /= server then Left (connId, Left $ CMD PROHIBITED) else Right rq
|
||||||
|
queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId)
|
||||||
|
|
||||||
addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
|
addSubscription :: MonadIO m => AgentClient -> RcvQueue -> ConnId -> m ()
|
||||||
addSubscription c rq@RcvQueue {server} connId = atomically $ do
|
addSubscription c rq@RcvQueue {server} connId = atomically $ do
|
||||||
|
@ -762,15 +795,16 @@ withStore c action = do
|
||||||
where
|
where
|
||||||
handleInternal :: E.SomeException -> IO (Either StoreError a)
|
handleInternal :: E.SomeException -> IO (Either StoreError a)
|
||||||
handleInternal = pure . Left . SEInternal . bshow
|
handleInternal = pure . Left . SEInternal . bshow
|
||||||
storeError :: StoreError -> AgentErrorType
|
|
||||||
storeError = \case
|
storeError :: StoreError -> AgentErrorType
|
||||||
SEConnNotFound -> CONN NOT_FOUND
|
storeError = \case
|
||||||
SEConnDuplicate -> CONN DUPLICATE
|
SEConnNotFound -> CONN NOT_FOUND
|
||||||
SEBadConnType CRcv -> CONN SIMPLEX
|
SEConnDuplicate -> CONN DUPLICATE
|
||||||
SEBadConnType CSnd -> CONN SIMPLEX
|
SEBadConnType CRcv -> CONN SIMPLEX
|
||||||
SEInvitationNotFound -> CMD PROHIBITED
|
SEBadConnType CSnd -> CONN SIMPLEX
|
||||||
-- this error is never reported as store error,
|
SEInvitationNotFound -> CMD PROHIBITED
|
||||||
-- it is used to wrap agent operations when "transaction-like" store access is needed
|
-- this error is never reported as store error,
|
||||||
-- NOTE: network IO should NOT be used inside AgentStoreMonad
|
-- it is used to wrap agent operations when "transaction-like" store access is needed
|
||||||
SEAgentError e -> e
|
-- NOTE: network IO should NOT be used inside AgentStoreMonad
|
||||||
e -> INTERNAL $ show e
|
SEAgentError e -> e
|
||||||
|
e -> INTERNAL $ show e
|
||||||
|
|
|
@ -16,8 +16,8 @@ module Simplex.Messaging.Agent.Store.SQLite.Migrations
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad (forM_)
|
import Control.Monad (forM_)
|
||||||
import Data.Function (on)
|
|
||||||
import Data.List (intercalate, sortBy)
|
import Data.List (intercalate, sortBy)
|
||||||
|
import Data.Ord (comparing)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Time.Clock (getCurrentTime)
|
import Data.Time.Clock (getCurrentTime)
|
||||||
import Database.SQLite.Simple (Connection, Only (..), Query (..))
|
import Database.SQLite.Simple (Connection, Only (..), Query (..))
|
||||||
|
@ -44,7 +44,7 @@ schemaMigrations =
|
||||||
|
|
||||||
-- | The list of migrations in ascending order by date
|
-- | The list of migrations in ascending order by date
|
||||||
app :: [Migration]
|
app :: [Migration]
|
||||||
app = sortBy (compare `on` name) $ map migration schemaMigrations
|
app = sortBy (comparing name) $ map migration schemaMigrations
|
||||||
where
|
where
|
||||||
migration (name, query) = Migration {name = name, up = fromQuery query}
|
migration (name, query) = Migration {name = name, up = fromQuery query}
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE NumericUnderscores #-}
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
@ -32,11 +33,14 @@ module Simplex.Messaging.Client
|
||||||
-- * SMP protocol command functions
|
-- * SMP protocol command functions
|
||||||
createSMPQueue,
|
createSMPQueue,
|
||||||
subscribeSMPQueue,
|
subscribeSMPQueue,
|
||||||
|
subscribeSMPQueues,
|
||||||
getSMPMessage,
|
getSMPMessage,
|
||||||
subscribeSMPQueueNotifications,
|
subscribeSMPQueueNotifications,
|
||||||
secureSMPQueue,
|
secureSMPQueue,
|
||||||
enableSMPQueueNotifications,
|
enableSMPQueueNotifications,
|
||||||
disableSMPQueueNotifications,
|
disableSMPQueueNotifications,
|
||||||
|
enableSMPQueuesNtfs,
|
||||||
|
disableSMPQueuesNtfs,
|
||||||
sendSMPMessage,
|
sendSMPMessage,
|
||||||
ackSMPMessage,
|
ackSMPMessage,
|
||||||
suspendSMPQueue,
|
suspendSMPQueue,
|
||||||
|
@ -60,6 +64,10 @@ import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
|
import Data.Either (rights)
|
||||||
|
import Data.Functor (($>))
|
||||||
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
|
import qualified Data.List.NonEmpty as L
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Network.Socket (ServiceName)
|
import Network.Socket (ServiceName)
|
||||||
import Numeric.Natural
|
import Numeric.Natural
|
||||||
|
@ -87,13 +95,16 @@ data ProtocolClient msg = ProtocolClient
|
||||||
tcpTimeout :: Int,
|
tcpTimeout :: Int,
|
||||||
clientCorrId :: TVar Natural,
|
clientCorrId :: TVar Natural,
|
||||||
sentCommands :: TMap CorrId (Request msg),
|
sentCommands :: TMap CorrId (Request msg),
|
||||||
sndQ :: TBQueue SentRawTransmission,
|
sndQ :: TBQueue (NonEmpty (SentRawTransmission)),
|
||||||
rcvQ :: TBQueue (SignedTransmission msg),
|
rcvQ :: TBQueue (NonEmpty (SignedTransmission msg)),
|
||||||
msgQ :: Maybe (TBQueue (ServerTransmission msg))
|
msgQ :: Maybe (TBQueue (ServerTransmission msg))
|
||||||
}
|
}
|
||||||
|
|
||||||
type SMPClient = ProtocolClient SMP.BrokerMsg
|
type SMPClient = ProtocolClient SMP.BrokerMsg
|
||||||
|
|
||||||
|
-- | Type for client command data
|
||||||
|
type ClientCommand msg = (Maybe C.APrivateSignKey, QueueId, ProtoCommand msg)
|
||||||
|
|
||||||
-- | Type synonym for transmission from some SPM server queue.
|
-- | Type synonym for transmission from some SPM server queue.
|
||||||
type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
|
type ServerTransmission msg = (ProtoServer msg, Version, SessionId, QueueId, msg)
|
||||||
|
|
||||||
|
@ -208,13 +219,15 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
|
||||||
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
|
runExceptT $ sendProtocolCommand c Nothing "" protocolPing
|
||||||
|
|
||||||
process :: ProtocolClient msg -> IO ()
|
process :: ProtocolClient msg -> IO ()
|
||||||
process c@ProtocolClient {rcvQ, sentCommands} = forever $ do
|
process c = forever $ atomically (readTBQueue $ rcvQ c) >>= mapM_ (processMsg c)
|
||||||
(_, _, (corrId, qId, respOrErr)) <- atomically $ readTBQueue rcvQ
|
|
||||||
|
processMsg :: ProtocolClient msg -> SignedTransmission msg -> IO ()
|
||||||
|
processMsg c@ProtocolClient {sentCommands} (_, _, (corrId, qId, respOrErr)) =
|
||||||
if B.null $ bs corrId
|
if B.null $ bs corrId
|
||||||
then sendMsg qId respOrErr
|
then sendMsg respOrErr
|
||||||
else do
|
else do
|
||||||
atomically (TM.lookup corrId sentCommands) >>= \case
|
atomically (TM.lookup corrId sentCommands) >>= \case
|
||||||
Nothing -> sendMsg qId respOrErr
|
Nothing -> sendMsg respOrErr
|
||||||
Just Request {queueId, responseVar} -> atomically $ do
|
Just Request {queueId, responseVar} -> atomically $ do
|
||||||
TM.delete corrId sentCommands
|
TM.delete corrId sentCommands
|
||||||
putTMVar responseVar $
|
putTMVar responseVar $
|
||||||
|
@ -226,8 +239,8 @@ getProtocolClient protocolServer cfg@ProtocolClientConfig {qSize, tcpTimeout, tc
|
||||||
_ -> Right r
|
_ -> Right r
|
||||||
else Left . PCEUnexpectedResponse $ bshow respOrErr
|
else Left . PCEUnexpectedResponse $ bshow respOrErr
|
||||||
where
|
where
|
||||||
sendMsg :: QueueId -> Either ErrorType msg -> IO ()
|
sendMsg :: Either ErrorType msg -> IO ()
|
||||||
sendMsg qId = \case
|
sendMsg = \case
|
||||||
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
|
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c qId msg) msgQ
|
||||||
-- TODO send everything else to errQ and log in agent
|
-- TODO send everything else to errQ and log in agent
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
@ -285,12 +298,22 @@ subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT Pr
|
||||||
subscribeSMPQueue c rpKey rId =
|
subscribeSMPQueue c rpKey rId =
|
||||||
sendSMPCommand c (Just rpKey) rId SUB >>= \case
|
sendSMPCommand c (Just rpKey) rId SUB >>= \case
|
||||||
OK -> return ()
|
OK -> return ()
|
||||||
cmd@MSG {} -> writeSMPMessage c rId cmd
|
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||||
r -> throwE . PCEUnexpectedResponse $ bshow r
|
r -> throwE . PCEUnexpectedResponse $ bshow r
|
||||||
|
|
||||||
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> ExceptT ProtocolClientError IO ()
|
-- | Subscribe to multiple SMP queues batching commands if supported.
|
||||||
writeSMPMessage c rId msg =
|
subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
|
||||||
liftIO . atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
|
subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM response . L.zip qs
|
||||||
|
where
|
||||||
|
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs
|
||||||
|
response ((_, rId), r) = case r of
|
||||||
|
Right OK -> pure $ Right ()
|
||||||
|
Right cmd@MSG {} -> writeSMPMessage c rId cmd $> Right ()
|
||||||
|
Right r' -> pure . Left . PCEUnexpectedResponse $ bshow r'
|
||||||
|
Left e -> pure $ Left e
|
||||||
|
|
||||||
|
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
|
||||||
|
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ c)
|
||||||
|
|
||||||
serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
|
serverTransmission :: ProtocolClient msg -> RecipientId -> msg -> ServerTransmission msg
|
||||||
serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
|
serverTransmission ProtocolClient {protocolServer, thVersion, sessionId} entityId message =
|
||||||
|
@ -303,9 +326,7 @@ getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT Protoc
|
||||||
getSMPMessage c rpKey rId =
|
getSMPMessage c rpKey rId =
|
||||||
sendSMPCommand c (Just rpKey) rId GET >>= \case
|
sendSMPCommand c (Just rpKey) rId GET >>= \case
|
||||||
OK -> pure Nothing
|
OK -> pure Nothing
|
||||||
cmd@(MSG msg) -> do
|
cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg
|
||||||
writeSMPMessage c rId cmd
|
|
||||||
pure $ Just msg
|
|
||||||
r -> throwE . PCEUnexpectedResponse $ bshow r
|
r -> throwE . PCEUnexpectedResponse $ bshow r
|
||||||
|
|
||||||
-- | Subscribe to the SMP queue notifications.
|
-- | Subscribe to the SMP queue notifications.
|
||||||
|
@ -329,12 +350,32 @@ enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey =
|
||||||
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
|
NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey)
|
||||||
r -> throwE . PCEUnexpectedResponse $ bshow r
|
r -> throwE . PCEUnexpectedResponse $ bshow r
|
||||||
|
|
||||||
|
-- | Enable notifications for the multiple queues for push notifications server.
|
||||||
|
enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either ProtocolClientError (NotifierId, RcvNtfPublicDhKey)))
|
||||||
|
enableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
|
||||||
|
where
|
||||||
|
cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs
|
||||||
|
response = \case
|
||||||
|
Right (NID nId rcvNtfSrvPublicDhKey) -> Right (nId, rcvNtfSrvPublicDhKey)
|
||||||
|
Right r -> Left . PCEUnexpectedResponse $ bshow r
|
||||||
|
Left e -> Left e
|
||||||
|
|
||||||
-- | Disable notifications for the queue for push notifications server.
|
-- | Disable notifications for the queue for push notifications server.
|
||||||
--
|
--
|
||||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
|
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command
|
||||||
disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
|
disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT ProtocolClientError IO ()
|
||||||
disableSMPQueueNotifications = okSMPCommand NDEL
|
disableSMPQueueNotifications = okSMPCommand NDEL
|
||||||
|
|
||||||
|
-- | Disable notifications for multiple queues for push notifications server.
|
||||||
|
disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either ProtocolClientError ()))
|
||||||
|
disableSMPQueuesNtfs c qs = L.map response <$> sendProtocolCommands c cs
|
||||||
|
where
|
||||||
|
cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient NDEL)) qs
|
||||||
|
response = \case
|
||||||
|
Right OK -> Right ()
|
||||||
|
Right r -> Left . PCEUnexpectedResponse $ bshow r
|
||||||
|
Left e -> Left e
|
||||||
|
|
||||||
-- | Send SMP message.
|
-- | Send SMP message.
|
||||||
--
|
--
|
||||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
|
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
|
||||||
|
@ -351,7 +392,7 @@ ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT P
|
||||||
ackSMPMessage c rpKey rId msgId =
|
ackSMPMessage c rpKey rId msgId =
|
||||||
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
|
sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case
|
||||||
OK -> return ()
|
OK -> return ()
|
||||||
cmd@MSG {} -> writeSMPMessage c rId cmd
|
cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd
|
||||||
r -> throwE . PCEUnexpectedResponse $ bshow r
|
r -> throwE . PCEUnexpectedResponse $ bshow r
|
||||||
|
|
||||||
-- | Irreversibly suspend SMP queue.
|
-- | Irreversibly suspend SMP queue.
|
||||||
|
@ -377,37 +418,48 @@ okSMPCommand cmd c pKey qId =
|
||||||
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
|
sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT ProtocolClientError IO BrokerMsg
|
||||||
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
|
sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd)
|
||||||
|
|
||||||
|
-- | Send multiple commands with batching and collect responses
|
||||||
|
sendProtocolCommands :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Either ProtocolClientError msg))
|
||||||
|
sendProtocolCommands c@ProtocolClient {sndQ, tcpTimeout} cs = do
|
||||||
|
ts <- mapM (runExceptT . mkTransmission c) cs
|
||||||
|
mapM_ (atomically . writeTBQueue sndQ . L.map fst) . L.nonEmpty . rights $ L.toList ts
|
||||||
|
forConcurrently ts $ \case
|
||||||
|
Right (_, r) -> withTimeout . atomically $ takeTMVar r
|
||||||
|
Left e -> pure $ Left e
|
||||||
|
where
|
||||||
|
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
|
||||||
|
|
||||||
-- | Send Protocol command
|
-- | Send Protocol command
|
||||||
sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
|
sendProtocolCommand :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> Maybe C.APrivateSignKey -> QueueId -> ProtoCommand msg -> ExceptT ProtocolClientError IO msg
|
||||||
sendProtocolCommand ProtocolClient {sndQ, sentCommands, clientCorrId, sessionId, thVersion, tcpTimeout} pKey qId cmd = do
|
sendProtocolCommand c@ProtocolClient {sndQ, tcpTimeout} pKey qId cmd = do
|
||||||
corrId <- lift_ getNextCorrId
|
(t, r) <- mkTransmission c (pKey, qId, cmd)
|
||||||
t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
|
ExceptT $ sendRecv t r
|
||||||
ExceptT $ sendRecv corrId t
|
|
||||||
where
|
where
|
||||||
lift_ :: STM a -> ExceptT ProtocolClientError IO a
|
-- two separate "atomically" needed to avoid blocking
|
||||||
lift_ action = ExceptT $ Right <$> atomically action
|
sendRecv :: SentRawTransmission -> TMVar (Response msg) -> IO (Response msg)
|
||||||
|
sendRecv t r = atomically (writeTBQueue sndQ [t]) >> withTimeout (atomically $ takeTMVar r)
|
||||||
|
where
|
||||||
|
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
|
||||||
|
|
||||||
|
mkTransmission :: forall msg. ProtocolEncoding (ProtoCommand msg) => ProtocolClient msg -> ClientCommand msg -> ExceptT ProtocolClientError IO (SentRawTransmission, TMVar (Response msg))
|
||||||
|
mkTransmission ProtocolClient {clientCorrId, sessionId, thVersion, sentCommands} (pKey, qId, cmd) = do
|
||||||
|
corrId <- liftIO $ atomically getNextCorrId
|
||||||
|
t <- signTransmission $ encodeTransmission thVersion sessionId (corrId, qId, cmd)
|
||||||
|
r <- liftIO . atomically $ mkRequest corrId
|
||||||
|
pure (t, r)
|
||||||
|
where
|
||||||
getNextCorrId :: STM CorrId
|
getNextCorrId :: STM CorrId
|
||||||
getNextCorrId = do
|
getNextCorrId = do
|
||||||
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
|
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
|
||||||
pure . CorrId $ bshow i
|
pure . CorrId $ bshow i
|
||||||
|
|
||||||
signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
|
signTransmission :: ByteString -> ExceptT ProtocolClientError IO SentRawTransmission
|
||||||
signTransmission t = case pKey of
|
signTransmission t = case pKey of
|
||||||
Nothing -> return (Nothing, t)
|
Nothing -> pure (Nothing, t)
|
||||||
Just pk -> do
|
Just pk -> do
|
||||||
sig <- liftError PCESignatureError $ C.sign pk t
|
sig <- liftError PCESignatureError $ C.sign pk t
|
||||||
return (Just sig, t)
|
return (Just sig, t)
|
||||||
|
mkRequest :: CorrId -> STM (TMVar (Response msg))
|
||||||
-- two separate "atomically" needed to avoid blocking
|
mkRequest corrId = do
|
||||||
sendRecv :: CorrId -> SentRawTransmission -> IO (Response msg)
|
|
||||||
sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
|
|
||||||
where
|
|
||||||
withTimeout a = fromMaybe (Left PCEResponseTimeout) <$> timeout tcpTimeout a
|
|
||||||
|
|
||||||
send :: CorrId -> SentRawTransmission -> STM (TMVar (Response msg))
|
|
||||||
send corrId t = do
|
|
||||||
r <- newEmptyTMVar
|
r <- newEmptyTMVar
|
||||||
TM.insert corrId (Request qId r) sentCommands
|
TM.insert corrId (Request qId r) sentCommands
|
||||||
writeTBQueue sndQ t
|
pure r
|
||||||
return r
|
|
||||||
|
|
|
@ -13,6 +13,7 @@ module Simplex.Messaging.Encoding
|
||||||
Large (..),
|
Large (..),
|
||||||
smpEncodeList,
|
smpEncodeList,
|
||||||
smpListP,
|
smpListP,
|
||||||
|
lenEncode,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
@ -248,22 +249,23 @@ clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connecte
|
||||||
|
|
||||||
receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
|
receive :: (Transport c, MonadUnliftIO m, MonadReader NtfEnv m) => THandle c -> NtfServerClient -> m ()
|
||||||
receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
|
receive th NtfServerClient {rcvQ, sndQ, activeAt} = forever $ do
|
||||||
t@(_, _, (corrId, entId, cmdOrError)) <- tGet th
|
ts <- tGet th
|
||||||
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
|
||||||
logDebug "received transmission"
|
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
||||||
case cmdOrError of
|
logDebug "received transmission"
|
||||||
Left e -> write sndQ (corrId, entId, NRErr e)
|
case cmdOrError of
|
||||||
Right cmd ->
|
Left e -> write sndQ (corrId, entId, NRErr e)
|
||||||
verifyNtfTransmission t cmd >>= \case
|
Right cmd ->
|
||||||
VRVerified req -> write rcvQ req
|
verifyNtfTransmission t cmd >>= \case
|
||||||
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
|
VRVerified req -> write rcvQ req
|
||||||
|
VRFailed -> write sndQ (corrId, entId, NRErr AUTH)
|
||||||
where
|
where
|
||||||
write q t = atomically $ writeTBQueue q t
|
write q t = atomically $ writeTBQueue q t
|
||||||
|
|
||||||
send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
|
send :: (Transport c, MonadUnliftIO m) => THandle c -> NtfServerClient -> m ()
|
||||||
send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
|
send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, activeAt} = forever $ do
|
||||||
t <- atomically $ readTBQueue sndQ
|
t <- atomically $ readTBQueue sndQ
|
||||||
void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
|
void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)]
|
||||||
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
||||||
|
|
||||||
-- instance Show a => Show (TVar a) where
|
-- instance Show a => Show (TVar a) where
|
||||||
|
|
|
@ -69,4 +69,4 @@ ntfClientHandshake c keyHash ntfVRange = do
|
||||||
Nothing -> throwError $ TEHandshake VERSION
|
Nothing -> throwError $ TEHandshake VERSION
|
||||||
|
|
||||||
ntfTHandle :: Transport c => c -> THandle c
|
ntfTHandle :: Transport c => c -> THandle c
|
||||||
ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0}
|
ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False}
|
||||||
|
|
|
@ -7,6 +7,7 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
|
@ -130,6 +131,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
import qualified Data.List.NonEmpty as L
|
||||||
import Data.Maybe (isNothing)
|
import Data.Maybe (isNothing)
|
||||||
import Data.String
|
import Data.String
|
||||||
import Data.Time.Clock.System (SystemTime (..))
|
import Data.Time.Clock.System (SystemTime (..))
|
||||||
|
@ -1010,20 +1013,51 @@ instance Encoding CommandError where
|
||||||
_ -> fail "bad command error type"
|
_ -> fail "bad command error type"
|
||||||
|
|
||||||
-- | Send signed SMP transmission to TCP transport.
|
-- | Send signed SMP transmission to TCP transport.
|
||||||
tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
|
tPut :: Transport c => THandle c -> NonEmpty (SentRawTransmission) -> IO (NonEmpty (Either TransportError ()))
|
||||||
tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t
|
tPut th trs
|
||||||
|
| batch th = tPutBatch [] $ L.map tEncode trs
|
||||||
|
| otherwise = forM trs $ tPutBlock th . tEncode
|
||||||
|
where
|
||||||
|
tPutBatch :: [Either TransportError ()] -> NonEmpty ByteString -> IO (NonEmpty (Either TransportError ()))
|
||||||
|
tPutBatch rs ts = do
|
||||||
|
let (n, s, ts_) = encodeBatch 0 "" ts
|
||||||
|
r <- if n == 0 then pure [Left TELargeMsg] else replicate n <$> tPutBlock th (lenEncode n `B.cons` s)
|
||||||
|
let rs' = rs <> r
|
||||||
|
case ts_ of
|
||||||
|
Just ts' -> tPutBatch rs' ts'
|
||||||
|
_ -> pure $ L.fromList rs'
|
||||||
|
encodeBatch :: Int -> ByteString -> NonEmpty ByteString -> (Int, ByteString, Maybe (NonEmpty ByteString))
|
||||||
|
encodeBatch n s ts@(t :| ts_)
|
||||||
|
| n == 255 = (n, s, Just ts)
|
||||||
|
| otherwise =
|
||||||
|
let s' = s <> smpEncode (Large t)
|
||||||
|
n' = n + 1
|
||||||
|
in if B.length s' > blockSize th - 1
|
||||||
|
then (n,s,) $ if n == 0 then L.nonEmpty ts_ else Just ts
|
||||||
|
else case L.nonEmpty ts_ of
|
||||||
|
Just ts' -> encodeBatch n' s' ts'
|
||||||
|
_ -> (n', s', Nothing)
|
||||||
|
tEncode (sig, tr) = smpEncode (C.signatureBytes sig) <> tr
|
||||||
|
|
||||||
encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
|
encodeTransmission :: ProtocolEncoding c => Version -> ByteString -> Transmission c -> ByteString
|
||||||
encodeTransmission v sessionId (CorrId corrId, queueId, command) =
|
encodeTransmission v sessionId (CorrId corrId, queueId, command) =
|
||||||
smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
|
smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command
|
||||||
|
|
||||||
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
|
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
|
||||||
tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
|
tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission))
|
||||||
tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
|
tGetParse th
|
||||||
|
| batch th = either ((:| []) . Left) id <$> runExceptT getBatch
|
||||||
|
| otherwise = (:| []) . (parse transmissionP TEBadBlock =<<) <$> tGetBlock th
|
||||||
|
where
|
||||||
|
getBatch :: ExceptT TransportError IO (NonEmpty (Either TransportError RawTransmission))
|
||||||
|
getBatch = do
|
||||||
|
s <- ExceptT $ tGetBlock th
|
||||||
|
ts <- liftEither $ parse smpP TEBadBlock s
|
||||||
|
pure $ L.map (\(Large t) -> parse transmissionP TEBadBlock t) ts
|
||||||
|
|
||||||
-- | Receive client and server transmissions (determined by `cmd` type).
|
-- | Receive client and server transmissions (determined by `cmd` type).
|
||||||
tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (SignedTransmission cmd)
|
tGet :: forall cmd c m. (ProtocolEncoding cmd, Transport c, MonadIO m) => THandle c -> m (NonEmpty (SignedTransmission cmd))
|
||||||
tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= decodeParseValidate
|
tGet th@THandle {sessionId, thVersion = v} = liftIO (tGetParse th) >>= mapM decodeParseValidate
|
||||||
where
|
where
|
||||||
decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
|
decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd)
|
||||||
decodeParseValidate = \case
|
decodeParseValidate = \case
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE NumericUnderscores #-}
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
@ -43,9 +44,10 @@ import Crypto.Random
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight, partitionEithers)
|
||||||
import Data.Functor (($>))
|
import Data.Functor (($>))
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
|
import qualified Data.List.NonEmpty as L
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Maybe (isNothing)
|
import Data.Maybe (isNothing)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
|
@ -145,7 +147,7 @@ smpServer started = do
|
||||||
endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
|
endPreviousSubscriptions :: (QueueId, Client) -> m (Maybe s)
|
||||||
endPreviousSubscriptions (qId, c) = do
|
endPreviousSubscriptions (qId, c) = do
|
||||||
void . forkIO . atomically $
|
void . forkIO . atomically $
|
||||||
writeTBQueue (sndQ c) (CorrId "", qId, END)
|
writeTBQueue (sndQ c) [(CorrId "", qId, END)]
|
||||||
atomically $ TM.lookupDelete qId (clientSubs c)
|
atomically $ TM.lookupDelete qId (clientSubs c)
|
||||||
|
|
||||||
expireMessagesThread_ :: ServerConfig -> [m ()]
|
expireMessagesThread_ :: ServerConfig -> [m ()]
|
||||||
|
@ -243,26 +245,36 @@ cancelSub sub =
|
||||||
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
|
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
|
receive :: forall c m. (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m ()
|
||||||
receive th Client {rcvQ, sndQ, activeAt} = forever $ do
|
receive th Client {rcvQ, sndQ, activeAt} = forever $ do
|
||||||
(sig, signed, (corrId, queueId, cmdOrError)) <- tGet th
|
ts <- L.toList <$> tGet th
|
||||||
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
||||||
case cmdOrError of
|
as <- partitionEithers <$> mapM cmdAction ts
|
||||||
Left e -> write sndQ (corrId, queueId, ERR e)
|
write sndQ $ fst as
|
||||||
Right cmd -> do
|
write rcvQ $ snd as
|
||||||
verified <- verifyTransmission sig signed queueId cmd
|
|
||||||
if verified
|
|
||||||
then write rcvQ (corrId, queueId, cmd)
|
|
||||||
else write sndQ (corrId, queueId, ERR AUTH)
|
|
||||||
where
|
where
|
||||||
write q t = atomically $ writeTBQueue q t
|
cmdAction :: SignedTransmission Cmd -> m (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd))
|
||||||
|
cmdAction (sig, signed, (corrId, queueId, cmdOrError)) =
|
||||||
|
case cmdOrError of
|
||||||
|
Left e -> pure $ Left (corrId, queueId, ERR e)
|
||||||
|
Right cmd -> verified <$> verifyTransmission sig signed queueId cmd
|
||||||
|
where
|
||||||
|
verified = \case
|
||||||
|
VRVerified qr -> Right (qr, (corrId, queueId, cmd))
|
||||||
|
VRFailed -> Left (corrId, queueId, ERR AUTH)
|
||||||
|
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
|
||||||
|
|
||||||
send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
|
send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m ()
|
||||||
send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
|
send h@THandle {thVersion = v} Client {sndQ, sessionId, activeAt} = forever $ do
|
||||||
t <- atomically $ readTBQueue sndQ
|
ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ
|
||||||
-- TODO the line below can return Left, but we ignore it and do not disconnect the client
|
-- TODO the line below can return Lefts, but we ignore it and do not disconnect the client
|
||||||
void . liftIO $ tPut h (Nothing, encodeTransmission v sessionId t)
|
void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts
|
||||||
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
atomically . writeTVar activeAt =<< liftIO getSystemTime
|
||||||
|
where
|
||||||
|
tOrder :: Transmission BrokerMsg -> Int
|
||||||
|
tOrder (_, _, cmd) = case cmd of
|
||||||
|
MSG {} -> 0
|
||||||
|
_ -> 1
|
||||||
|
|
||||||
disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
|
disconnectTransport :: (Transport c, MonadUnliftIO m) => THandle c -> client -> (client -> TVar SystemTime) -> ExpirationConfig -> m ()
|
||||||
disconnectTransport THandle {connection} c activeAt expCfg = do
|
disconnectTransport THandle {connection} c activeAt expCfg = do
|
||||||
|
@ -273,23 +285,28 @@ disconnectTransport THandle {connection} c activeAt expCfg = do
|
||||||
ts <- readTVarIO $ activeAt c
|
ts <- readTVarIO $ activeAt c
|
||||||
when (systemSeconds ts < old) $ closeConnection connection
|
when (systemSeconds ts < old) $ closeConnection connection
|
||||||
|
|
||||||
|
data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
|
||||||
|
|
||||||
verifyTransmission ::
|
verifyTransmission ::
|
||||||
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool
|
forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m VerificationResult
|
||||||
verifyTransmission sig_ signed queueId cmd = do
|
verifyTransmission sig_ signed queueId cmd = do
|
||||||
case cmd of
|
case cmd of
|
||||||
Cmd SRecipient (NEW k _) -> pure $ verifyCmdSignature sig_ signed k
|
Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
|
||||||
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
|
Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
|
||||||
Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
|
Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
|
||||||
Cmd SSender PING -> pure True
|
Cmd SSender PING -> pure $ VRVerified Nothing
|
||||||
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
|
Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier
|
||||||
where
|
where
|
||||||
verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool
|
verifyCmd :: SParty p -> (QueueRec -> Bool) -> m VerificationResult
|
||||||
verifyCmd party f = do
|
verifyCmd party f = do
|
||||||
st <- asks queueStore
|
st <- asks queueStore
|
||||||
q <- atomically $ getQueue st party queueId
|
q_ <- atomically (getQueue st party queueId)
|
||||||
pure $ either (const $ maybe False (dummyVerifyCmd signed) sig_ `seq` False) f q
|
pure $ case q_ of
|
||||||
|
Right q -> Just q `verified` f q
|
||||||
|
_ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed
|
||||||
verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
|
verifyMaybe :: Maybe C.APublicVerifyKey -> Bool
|
||||||
verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
|
verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed
|
||||||
|
verified q cond = if cond then VRVerified q else VRFailed
|
||||||
|
|
||||||
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
|
verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool
|
||||||
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
|
verifyCmdSignature sig_ signed key = maybe False (verify key) sig_
|
||||||
|
@ -320,16 +337,16 @@ client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server ->
|
||||||
client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
|
client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
|
||||||
forever $
|
forever $
|
||||||
atomically (readTBQueue rcvQ)
|
atomically (readTBQueue rcvQ)
|
||||||
>>= processCommand
|
>>= mapM processCommand
|
||||||
>>= atomically . writeTBQueue sndQ
|
>>= atomically . writeTBQueue sndQ
|
||||||
where
|
where
|
||||||
processCommand :: Transmission Cmd -> m (Transmission BrokerMsg)
|
processCommand :: (Maybe QueueRec, Transmission Cmd) -> m (Transmission BrokerMsg)
|
||||||
processCommand (corrId, queueId, cmd) = do
|
processCommand (qr_, (corrId, queueId, cmd)) = do
|
||||||
st <- asks queueStore
|
st <- asks queueStore
|
||||||
case cmd of
|
case cmd of
|
||||||
Cmd SSender command ->
|
Cmd SSender command ->
|
||||||
case command of
|
case command of
|
||||||
SEND flags msgBody -> sendMessage st flags msgBody
|
SEND flags msgBody -> withQueue $ \qr -> sendMessage qr flags msgBody
|
||||||
PING -> pure (corrId, "", PONG)
|
PING -> pure (corrId, "", PONG)
|
||||||
Cmd SNotifier NSUB -> subscribeNotifications
|
Cmd SNotifier NSUB -> subscribeNotifications
|
||||||
Cmd SRecipient command ->
|
Cmd SRecipient command ->
|
||||||
|
@ -339,9 +356,9 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
(asks $ allowNewQueues . config)
|
(asks $ allowNewQueues . config)
|
||||||
(createQueue st rKey dhKey)
|
(createQueue st rKey dhKey)
|
||||||
(pure (corrId, queueId, ERR AUTH))
|
(pure (corrId, queueId, ERR AUTH))
|
||||||
SUB -> subscribeQueue st queueId
|
SUB -> withQueue (`subscribeQueue` queueId)
|
||||||
GET -> getMessage st
|
GET -> withQueue getMessage
|
||||||
ACK msgId -> acknowledgeMsg st msgId
|
ACK msgId -> withQueue (`acknowledgeMsg` msgId)
|
||||||
KEY sKey -> secureQueue_ st sKey
|
KEY sKey -> secureQueue_ st sKey
|
||||||
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
|
NKEY nKey dhKey -> addQueueNotifier_ st nKey dhKey
|
||||||
NDEL -> deleteQueueNotifier_ st
|
NDEL -> deleteQueueNotifier_ st
|
||||||
|
@ -371,14 +388,15 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
addQueueRetry n qik qRec = do
|
addQueueRetry n qik qRec = do
|
||||||
ids@(rId, _) <- getIds
|
ids@(rId, _) <- getIds
|
||||||
-- create QueueRec record with these ids and keys
|
-- create QueueRec record with these ids and keys
|
||||||
atomically (addQueue st $ qRec ids) >>= \case
|
let qr = qRec ids
|
||||||
|
atomically (addQueue st qr) >>= \case
|
||||||
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
|
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
|
||||||
Left e -> pure $ ERR e
|
Left e -> pure $ ERR e
|
||||||
Right _ -> do
|
Right _ -> do
|
||||||
withLog (`logCreateById` rId)
|
withLog (`logCreateById` rId)
|
||||||
stats <- asks serverStats
|
stats <- asks serverStats
|
||||||
atomically $ modifyTVar (qCreated stats) (+ 1)
|
atomically $ modifyTVar (qCreated stats) (+ 1)
|
||||||
subscribeQueue st rId $> IDS (qik ids)
|
subscribeQueue qr rId $> IDS (qik ids)
|
||||||
|
|
||||||
logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
|
logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
|
||||||
logCreateById s rId =
|
logCreateById s rId =
|
||||||
|
@ -426,8 +444,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
withLog (`logDeleteQueue` queueId)
|
withLog (`logDeleteQueue` queueId)
|
||||||
okResp <$> atomically (suspendQueue st queueId)
|
okResp <$> atomically (suspendQueue st queueId)
|
||||||
|
|
||||||
subscribeQueue :: QueueStore -> RecipientId -> m (Transmission BrokerMsg)
|
subscribeQueue :: QueueRec -> RecipientId -> m (Transmission BrokerMsg)
|
||||||
subscribeQueue st rId =
|
subscribeQueue qr rId =
|
||||||
atomically (TM.lookup rId subscriptions) >>= \case
|
atomically (TM.lookup rId subscriptions) >>= \case
|
||||||
Nothing ->
|
Nothing ->
|
||||||
atomically newSub >>= deliver
|
atomically newSub >>= deliver
|
||||||
|
@ -449,10 +467,10 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
deliver sub = do
|
deliver sub = do
|
||||||
q <- getStoreMsgQueue rId
|
q <- getStoreMsgQueue rId
|
||||||
msg_ <- atomically $ tryPeekMsg q
|
msg_ <- atomically $ tryPeekMsg q
|
||||||
deliverMessage st rId sub q msg_
|
deliverMessage qr rId sub q msg_
|
||||||
|
|
||||||
getMessage :: QueueStore -> m (Transmission BrokerMsg)
|
getMessage :: QueueRec -> m (Transmission BrokerMsg)
|
||||||
getMessage st =
|
getMessage qr =
|
||||||
atomically (TM.lookup queueId subscriptions) >>= \case
|
atomically (TM.lookup queueId subscriptions) >>= \case
|
||||||
Nothing ->
|
Nothing ->
|
||||||
atomically newSub >>= getMessage_
|
atomically newSub >>= getMessage_
|
||||||
|
@ -471,7 +489,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
TM.insert queueId sub subscriptions
|
TM.insert queueId sub subscriptions
|
||||||
pure s
|
pure s
|
||||||
getMessage_ :: Sub -> m (Transmission BrokerMsg)
|
getMessage_ :: Sub -> m (Transmission BrokerMsg)
|
||||||
getMessage_ s = withRcvQueue st queueId $ \qr -> do
|
getMessage_ s = do
|
||||||
q <- getStoreMsgQueue queueId
|
q <- getStoreMsgQueue queueId
|
||||||
atomically $
|
atomically $
|
||||||
tryPeekMsg q >>= \case
|
tryPeekMsg q >>= \case
|
||||||
|
@ -480,11 +498,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
in setDelivered s msg $> (corrId, queueId, MSG encMsg)
|
in setDelivered s msg $> (corrId, queueId, MSG encMsg)
|
||||||
_ -> pure (corrId, queueId, OK)
|
_ -> pure (corrId, queueId, OK)
|
||||||
|
|
||||||
withRcvQueue :: QueueStore -> RecipientId -> (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
|
withQueue :: (QueueRec -> m (Transmission BrokerMsg)) -> m (Transmission BrokerMsg)
|
||||||
withRcvQueue st rId action =
|
withQueue action = maybe (pure $ err AUTH) action qr_
|
||||||
atomically (getQueue st SRecipient rId) >>= \case
|
|
||||||
Left e -> pure (corrId, rId, ERR e)
|
|
||||||
Right qr -> action qr
|
|
||||||
|
|
||||||
subscribeNotifications :: m (Transmission BrokerMsg)
|
subscribeNotifications :: m (Transmission BrokerMsg)
|
||||||
subscribeNotifications = atomically $ do
|
subscribeNotifications = atomically $ do
|
||||||
|
@ -493,8 +508,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
TM.insert queueId () ntfSubscriptions
|
TM.insert queueId () ntfSubscriptions
|
||||||
pure ok
|
pure ok
|
||||||
|
|
||||||
acknowledgeMsg :: QueueStore -> MsgId -> m (Transmission BrokerMsg)
|
acknowledgeMsg :: QueueRec -> MsgId -> m (Transmission BrokerMsg)
|
||||||
acknowledgeMsg st msgId = do
|
acknowledgeMsg qr msgId = do
|
||||||
atomically (TM.lookup queueId subscriptions) >>= \case
|
atomically (TM.lookup queueId subscriptions) >>= \case
|
||||||
Nothing -> pure $ err NO_MSG
|
Nothing -> pure $ err NO_MSG
|
||||||
Just sub ->
|
Just sub ->
|
||||||
|
@ -509,7 +524,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
_ -> do
|
_ -> do
|
||||||
(msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
|
(msgDeleted, msg_) <- atomically $ tryDelPeekMsg q msgId
|
||||||
when msgDeleted updateStats
|
when msgDeleted updateStats
|
||||||
deliverMessage st queueId sub q msg_
|
deliverMessage qr queueId sub q msg_
|
||||||
_ -> pure $ err NO_MSG
|
_ -> pure $ err NO_MSG
|
||||||
where
|
where
|
||||||
getDelivered :: TVar Sub -> STM (Maybe Sub)
|
getDelivered :: TVar Sub -> STM (Maybe Sub)
|
||||||
|
@ -533,74 +548,69 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
where
|
where
|
||||||
updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
|
updatePeriod pSel = modifyTVar (pSel stats) (S.insert qId)
|
||||||
|
|
||||||
sendMessage :: QueueStore -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
|
sendMessage :: QueueRec -> MsgFlags -> MsgBody -> m (Transmission BrokerMsg)
|
||||||
sendMessage st msgFlags msgBody
|
sendMessage qr msgFlags msgBody
|
||||||
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
|
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
|
||||||
| otherwise = do
|
| otherwise = case status qr of
|
||||||
qr <- atomically $ getQueue st SSender queueId
|
QueueOff -> return $ err AUTH
|
||||||
either (return . err) storeMessage qr
|
QueueActive ->
|
||||||
|
mapM mkMessage (C.maxLenBS msgBody) >>= \case
|
||||||
|
Left _ -> pure $ err LARGE_MSG
|
||||||
|
Right msg -> do
|
||||||
|
ms <- asks msgStore
|
||||||
|
ServerConfig {messageExpiration, msgQueueQuota} <- asks config
|
||||||
|
old <- liftIO $ mapM expireBeforeEpoch messageExpiration
|
||||||
|
ntfNonceDrg <- asks idsDrg
|
||||||
|
resp@(_, _, sent) <- atomically $ do
|
||||||
|
q <- getMsgQueue ms (recipientId qr) msgQueueQuota
|
||||||
|
mapM_ (deleteExpiredMsgs q) old
|
||||||
|
ifM (isFull q) (pure $ err QUOTA) $ do
|
||||||
|
when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
|
||||||
|
writeMsg q msg
|
||||||
|
pure ok
|
||||||
|
when (sent == OK) $ do
|
||||||
|
stats <- asks serverStats
|
||||||
|
atomically $ modifyTVar (msgSent stats) (+ 1)
|
||||||
|
atomically $ updateActiveQueues stats $ recipientId qr
|
||||||
|
pure resp
|
||||||
where
|
where
|
||||||
storeMessage :: QueueRec -> m (Transmission BrokerMsg)
|
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
|
||||||
storeMessage qr = case status qr of
|
mkMessage body = do
|
||||||
QueueOff -> return $ err AUTH
|
msgId <- randomId =<< asks (msgIdBytes . config)
|
||||||
QueueActive ->
|
msgTs <- liftIO getSystemTime
|
||||||
mapM mkMessage (C.maxLenBS msgBody) >>= \case
|
pure $ Message msgId msgTs msgFlags body
|
||||||
Left _ -> pure $ err LARGE_MSG
|
|
||||||
Right msg -> do
|
|
||||||
ms <- asks msgStore
|
|
||||||
ServerConfig {messageExpiration, msgQueueQuota} <- asks config
|
|
||||||
old <- liftIO $ mapM expireBeforeEpoch messageExpiration
|
|
||||||
ntfNonceDrg <- asks idsDrg
|
|
||||||
resp@(_, _, sent) <- atomically $ do
|
|
||||||
q <- getMsgQueue ms (recipientId qr) msgQueueQuota
|
|
||||||
mapM_ (deleteExpiredMsgs q) old
|
|
||||||
ifM (isFull q) (pure $ err QUOTA) $ do
|
|
||||||
when (notification msgFlags) $ trySendNotification msg ntfNonceDrg
|
|
||||||
writeMsg q msg
|
|
||||||
pure ok
|
|
||||||
when (sent == OK) $ do
|
|
||||||
stats <- asks serverStats
|
|
||||||
atomically $ modifyTVar (msgSent stats) (+ 1)
|
|
||||||
atomically $ updateActiveQueues stats $ recipientId qr
|
|
||||||
pure resp
|
|
||||||
where
|
|
||||||
mkMessage :: C.MaxLenBS MaxMessageLen -> m Message
|
|
||||||
mkMessage body = do
|
|
||||||
msgId <- randomId =<< asks (msgIdBytes . config)
|
|
||||||
msgTs <- liftIO getSystemTime
|
|
||||||
pure $ Message msgId msgTs msgFlags body
|
|
||||||
|
|
||||||
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
|
trySendNotification :: Message -> TVar ChaChaDRG -> STM ()
|
||||||
trySendNotification msg ntfNonceDrg =
|
trySendNotification msg ntfNonceDrg =
|
||||||
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
|
forM_ (notifier qr) $ \NtfCreds {notifierId, rcvNtfDhSecret} ->
|
||||||
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
|
mapM_ (writeNtf notifierId msg rcvNtfDhSecret ntfNonceDrg) =<< TM.lookup notifierId notifiers
|
||||||
|
|
||||||
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
|
writeNtf :: NotifierId -> Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> Client -> STM ()
|
||||||
writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
|
writeNtf nId msg rcvNtfDhSecret ntfNonceDrg Client {sndQ = q} =
|
||||||
unlessM (isFullTBQueue sndQ) $ do
|
unlessM (isFullTBQueue sndQ) $ do
|
||||||
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
|
(nmsgNonce, encNMsgMeta) <- mkMessageNotification msg rcvNtfDhSecret ntfNonceDrg
|
||||||
writeTBQueue q (CorrId "", nId, NMSG nmsgNonce encNMsgMeta)
|
writeTBQueue q [(CorrId "", nId, NMSG nmsgNonce encNMsgMeta)]
|
||||||
|
|
||||||
mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
|
mkMessageNotification :: Message -> RcvNtfDhSecret -> TVar ChaChaDRG -> STM (C.CbNonce, EncNMsgMeta)
|
||||||
mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
|
mkMessageNotification Message {msgId, msgTs} rcvNtfDhSecret ntfNonceDrg = do
|
||||||
cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
|
cbNonce <- C.pseudoRandomCbNonce ntfNonceDrg
|
||||||
let msgMeta = NMsgMeta {msgId, msgTs}
|
let msgMeta = NMsgMeta {msgId, msgTs}
|
||||||
encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
|
encNMsgMeta = C.cbEncrypt rcvNtfDhSecret cbNonce (smpEncode msgMeta) 128
|
||||||
pure . (cbNonce,) $ fromRight "" encNMsgMeta
|
pure . (cbNonce,) $ fromRight "" encNMsgMeta
|
||||||
|
|
||||||
deliverMessage :: QueueStore -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
|
deliverMessage :: QueueRec -> RecipientId -> TVar Sub -> MsgQueue -> Maybe Message -> m (Transmission BrokerMsg)
|
||||||
deliverMessage st rId sub q msg_ = withRcvQueue st rId $ \qr -> do
|
deliverMessage qr rId sub q msg_ = do
|
||||||
readTVarIO sub >>= \case
|
readTVarIO sub >>= \case
|
||||||
s@Sub {subThread = NoSub} ->
|
s@Sub {subThread = NoSub} ->
|
||||||
case msg_ of
|
case msg_ of
|
||||||
Just msg ->
|
Just msg ->
|
||||||
let encMsg = encryptMsg qr msg
|
let encMsg = encryptMsg qr msg
|
||||||
in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
|
in atomically (setDelivered s msg) $> (corrId, rId, MSG encMsg)
|
||||||
_ -> forkSub qr $> ok
|
_ -> forkSub $> ok
|
||||||
_ -> pure ok
|
_ -> pure ok
|
||||||
where
|
where
|
||||||
forkSub :: QueueRec -> m ()
|
forkSub :: m ()
|
||||||
forkSub qr = do
|
forkSub = do
|
||||||
atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
|
atomically . modifyTVar sub $ \s -> s {subThread = SubPending}
|
||||||
t <- mkWeakThreadId =<< forkIO subscriber
|
t <- mkWeakThreadId =<< forkIO subscriber
|
||||||
atomically . modifyTVar sub $ \case
|
atomically . modifyTVar sub $ \case
|
||||||
|
@ -610,7 +620,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv
|
||||||
subscriber = atomically $ do
|
subscriber = atomically $ do
|
||||||
msg <- peekMsg q
|
msg <- peekMsg q
|
||||||
let encMsg = encryptMsg qr msg
|
let encMsg = encryptMsg qr msg
|
||||||
writeTBQueue sndQ (CorrId "", rId, MSG encMsg)
|
writeTBQueue sndQ [(CorrId "", rId, MSG encMsg)]
|
||||||
s <- readTVar sub
|
s <- readTVar sub
|
||||||
void $ setDelivered s msg
|
void $ setDelivered s msg
|
||||||
writeTVar sub s {subThread = NoSub}
|
writeTVar sub s {subThread = NoSub}
|
||||||
|
|
|
@ -9,6 +9,7 @@ import Control.Concurrent (ThreadId)
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
import Crypto.Random
|
import Crypto.Random
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
|
import Data.List.NonEmpty (NonEmpty)
|
||||||
import Data.Map.Strict (Map)
|
import Data.Map.Strict (Map)
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Time.Clock (getCurrentTime)
|
import Data.Time.Clock (getCurrentTime)
|
||||||
|
@ -103,8 +104,8 @@ data Server = Server
|
||||||
data Client = Client
|
data Client = Client
|
||||||
{ subscriptions :: TMap RecipientId (TVar Sub),
|
{ subscriptions :: TMap RecipientId (TVar Sub),
|
||||||
ntfSubscriptions :: TMap NotifierId (),
|
ntfSubscriptions :: TMap NotifierId (),
|
||||||
rcvQ :: TBQueue (Transmission Cmd),
|
rcvQ :: TBQueue (NonEmpty (Maybe QueueRec, Transmission Cmd)),
|
||||||
sndQ :: TBQueue (Transmission BrokerMsg),
|
sndQ :: TBQueue (NonEmpty (Transmission BrokerMsg)),
|
||||||
thVersion :: Version,
|
thVersion :: Version,
|
||||||
sessionId :: ByteString,
|
sessionId :: ByteString,
|
||||||
connected :: TVar Bool,
|
connected :: TVar Bool,
|
||||||
|
|
|
@ -96,7 +96,7 @@ smpBlockSize :: Int
|
||||||
smpBlockSize = 16384
|
smpBlockSize = 16384
|
||||||
|
|
||||||
supportedSMPServerVRange :: VersionRange
|
supportedSMPServerVRange :: VersionRange
|
||||||
supportedSMPServerVRange = mkVersionRange 1 3
|
supportedSMPServerVRange = mkVersionRange 1 4
|
||||||
|
|
||||||
simplexMQVersion :: String
|
simplexMQVersion :: String
|
||||||
simplexMQVersion = "3.0.1"
|
simplexMQVersion = "3.0.1"
|
||||||
|
@ -258,7 +258,10 @@ data THandle c = THandle
|
||||||
sessionId :: SessionId,
|
sessionId :: SessionId,
|
||||||
blockSize :: Int,
|
blockSize :: Int,
|
||||||
-- | agreed server protocol version
|
-- | agreed server protocol version
|
||||||
thVersion :: Version
|
thVersion :: Version,
|
||||||
|
-- | send multiple transmissions in a single block
|
||||||
|
-- based on protocol and protocol version
|
||||||
|
batch :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | TLS-unique channel binding
|
-- | TLS-unique channel binding
|
||||||
|
@ -364,7 +367,7 @@ smpServerHandshake c kh smpVRange = do
|
||||||
| keyHash /= kh ->
|
| keyHash /= kh ->
|
||||||
throwE $ TEHandshake IDENTITY
|
throwE $ TEHandshake IDENTITY
|
||||||
| smpVersion `isCompatible` smpVRange -> do
|
| smpVersion `isCompatible` smpVRange -> do
|
||||||
pure (th :: THandle c) {thVersion = smpVersion}
|
pure $ smpThHandle th smpVersion
|
||||||
| otherwise -> throwE $ TEHandshake VERSION
|
| otherwise -> throwE $ TEHandshake VERSION
|
||||||
|
|
||||||
-- | Client SMP transport handshake.
|
-- | Client SMP transport handshake.
|
||||||
|
@ -379,9 +382,12 @@ smpClientHandshake c keyHash smpVRange = do
|
||||||
else case smpVersionRange `compatibleVersion` smpVRange of
|
else case smpVersionRange `compatibleVersion` smpVRange of
|
||||||
Just (Compatible smpVersion) -> do
|
Just (Compatible smpVersion) -> do
|
||||||
sendHandshake th $ ClientHandshake {smpVersion, keyHash}
|
sendHandshake th $ ClientHandshake {smpVersion, keyHash}
|
||||||
pure (th :: THandle c) {thVersion = smpVersion}
|
pure $ smpThHandle th smpVersion
|
||||||
Nothing -> throwE $ TEHandshake VERSION
|
Nothing -> throwE $ TEHandshake VERSION
|
||||||
|
|
||||||
|
smpThHandle :: forall c. THandle c -> Version -> THandle c
|
||||||
|
smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4}
|
||||||
|
|
||||||
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
|
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
|
||||||
sendHandshake th = ExceptT . tPutBlock th . smpEncode
|
sendHandshake th = ExceptT . tPutBlock th . smpEncode
|
||||||
|
|
||||||
|
@ -389,4 +395,4 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr
|
||||||
getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
|
getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th
|
||||||
|
|
||||||
smpTHandle :: Transport c => c -> THandle c
|
smpTHandle :: Transport c => c -> THandle c
|
||||||
smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0}
|
smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False}
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
|
|
@ -17,12 +17,16 @@ module AgentTests.FunctionalAPITests
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Concurrent (threadDelay)
|
import Control.Concurrent (killThread, threadDelay)
|
||||||
|
import Control.Monad
|
||||||
import Control.Monad.Except (ExceptT, runExceptT)
|
import Control.Monad.Except (ExceptT, runExceptT)
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
|
import Data.Int (Int64)
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Set as S
|
||||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
import Data.Time.Clock.System (SystemTime (..), getSystemTime)
|
||||||
import SMPAgentClient
|
import SMPAgentClient
|
||||||
import SMPClient (cfg, testPort, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
|
import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn)
|
||||||
import Simplex.Messaging.Agent
|
import Simplex.Messaging.Agent
|
||||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
||||||
import Simplex.Messaging.Agent.Protocol
|
import Simplex.Messaging.Agent.Protocol
|
||||||
|
@ -102,6 +106,9 @@ functionalAPITests t = do
|
||||||
testSuspendingAgentCompleteSending t
|
testSuspendingAgentCompleteSending t
|
||||||
it "should suspend agent on timeout, even if pending messages not sent" $
|
it "should suspend agent on timeout, even if pending messages not sent" $
|
||||||
testSuspendingAgentTimeout t
|
testSuspendingAgentTimeout t
|
||||||
|
describe "Batching SMP commands" $ do
|
||||||
|
it "should subscribe to multiple subscriptions with batching" $
|
||||||
|
testBatchedSubscriptions t
|
||||||
|
|
||||||
testAgentClient :: IO ()
|
testAgentClient :: IO ()
|
||||||
testAgentClient = do
|
testAgentClient = do
|
||||||
|
@ -503,13 +510,64 @@ testSuspendingAgentTimeout t = do
|
||||||
|
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
|
testBatchedSubscriptions :: ATransport -> IO ()
|
||||||
|
testBatchedSubscriptions t = do
|
||||||
|
a <- getSMPAgentClient agentCfg initAgentServers2
|
||||||
|
b <- getSMPAgentClient agentCfg {dbFile = testDB2} initAgentServers2
|
||||||
|
Right conns <- runServers $ do
|
||||||
|
conns <- forM [1 .. 200 :: Int] . const $ makeConnection a b
|
||||||
|
forM_ conns $ \(aId, bId) -> exchangeGreetings a bId b aId
|
||||||
|
forM_ (take 10 conns) $ \(aId, bId) -> do
|
||||||
|
deleteConnection a bId
|
||||||
|
deleteConnection b aId
|
||||||
|
liftIO $ threadDelay 1000000
|
||||||
|
pure conns
|
||||||
|
("", "", DOWN {}) <- get a
|
||||||
|
("", "", DOWN {}) <- get a
|
||||||
|
("", "", DOWN {}) <- get b
|
||||||
|
("", "", DOWN {}) <- get b
|
||||||
|
Right () <- runServers $ do
|
||||||
|
("", "", UP {}) <- get a
|
||||||
|
("", "", UP {}) <- get a
|
||||||
|
("", "", UP {}) <- get b
|
||||||
|
("", "", UP {}) <- get b
|
||||||
|
liftIO $ threadDelay 1000000
|
||||||
|
subscribe a $ map snd conns
|
||||||
|
subscribe b $ map fst conns
|
||||||
|
forM_ (drop 10 conns) $ \(aId, bId) -> exchangeGreetingsMsgId 6 a bId b aId
|
||||||
|
pure ()
|
||||||
|
where
|
||||||
|
subscribe :: AgentClient -> [ConnId] -> ExceptT AgentErrorType IO ()
|
||||||
|
subscribe c cs = do
|
||||||
|
r <- subscribeConnections c cs
|
||||||
|
liftIO $ do
|
||||||
|
let dc = S.fromList $ take 10 cs
|
||||||
|
all (== Right ()) (M.withoutKeys r dc) `shouldBe` True
|
||||||
|
all (== Left (CONN NOT_FOUND)) (M.restrictKeys r dc) `shouldBe` True
|
||||||
|
M.keys r `shouldMatchList` cs
|
||||||
|
runServers :: ExceptT AgentErrorType IO a -> IO (Either AgentErrorType a)
|
||||||
|
runServers a = do
|
||||||
|
withSmpServerStoreLogOn t testPort $ \t1 -> do
|
||||||
|
res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> do
|
||||||
|
res <- runExceptT a
|
||||||
|
killThread t2
|
||||||
|
pure res
|
||||||
|
killThread t1
|
||||||
|
pure res
|
||||||
|
|
||||||
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||||
exchangeGreetings alice bobId bob aliceId = do
|
exchangeGreetings = exchangeGreetingsMsgId 4
|
||||||
4 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
|
||||||
get alice ##> ("", bobId, SENT 4)
|
exchangeGreetingsMsgId :: Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||||
|
exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
|
||||||
|
msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||||
|
liftIO $ msgId1 `shouldBe` msgId
|
||||||
|
get alice ##> ("", bobId, SENT msgId)
|
||||||
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False
|
||||||
ackMessage bob aliceId 4
|
ackMessage bob aliceId msgId
|
||||||
5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
msgId2 <- sendMessage bob aliceId SMP.noMsgFlags "hello too"
|
||||||
get bob ##> ("", aliceId, SENT 5)
|
let msgId' = msgId + 1
|
||||||
|
liftIO $ msgId2 `shouldBe` msgId'
|
||||||
|
get bob ##> ("", aliceId, SENT msgId')
|
||||||
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False
|
||||||
ackMessage alice bobId 5
|
ackMessage alice bobId msgId'
|
||||||
|
|
|
@ -22,7 +22,6 @@ import NtfClient
|
||||||
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
|
import SMPAgentClient (agentCfg, initAgentServers, testDB, testDB2)
|
||||||
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
|
import SMPClient (testPort, withSmpServer, withSmpServerStoreLogOn)
|
||||||
import Simplex.Messaging.Agent
|
import Simplex.Messaging.Agent
|
||||||
import Simplex.Messaging.Agent.Client (AgentClient)
|
|
||||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
||||||
import Simplex.Messaging.Agent.Protocol
|
import Simplex.Messaging.Agent.Protocol
|
||||||
import qualified Simplex.Messaging.Crypto as C
|
import qualified Simplex.Messaging.Crypto as C
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE NumericUnderscores #-}
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
|
@ -140,10 +141,10 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
|
||||||
where
|
where
|
||||||
tPut' h (sig, corrId, queueId, smp) = do
|
tPut' h (sig, corrId, queueId, smp) = do
|
||||||
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
|
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
|
||||||
Right () <- tPut h (sig, t')
|
[Right ()] <- tPut h [(sig, t')]
|
||||||
pure ()
|
pure ()
|
||||||
tGet' h = do
|
tGet' h = do
|
||||||
(Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
|
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
|
||||||
pure (Nothing, corrId, qId, cmd)
|
pure (Nothing, corrId, qId, cmd)
|
||||||
|
|
||||||
ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
ntfTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
||||||
|
|
|
@ -25,6 +25,8 @@ import ServerTests
|
||||||
samplePubKey,
|
samplePubKey,
|
||||||
sampleSig,
|
sampleSig,
|
||||||
signSendRecv,
|
signSendRecv,
|
||||||
|
tGet1,
|
||||||
|
tPut1,
|
||||||
(#==),
|
(#==),
|
||||||
_SEND',
|
_SEND',
|
||||||
pattern Resp,
|
pattern Resp,
|
||||||
|
@ -69,15 +71,15 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
|
||||||
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
|
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
|
||||||
sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
|
sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
|
||||||
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
||||||
Right () <- tPut h (sgn, t)
|
Right () <- tPut1 h (sgn, t)
|
||||||
tGet h
|
tGet1 h
|
||||||
|
|
||||||
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
|
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
|
||||||
signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
|
signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
|
||||||
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
||||||
Right sig <- runExceptT $ C.sign pk t
|
Right sig <- runExceptT $ C.sign pk t
|
||||||
Right () <- tPut h (Just sig, t)
|
Right () <- tPut1 h (Just sig, t)
|
||||||
tGet h
|
tGet1 h
|
||||||
|
|
||||||
(.->) :: J.Value -> J.Key -> Either String ByteString
|
(.->) :: J.Value -> J.Key -> Either String ByteString
|
||||||
v .-> key =
|
v .-> key =
|
||||||
|
@ -132,7 +134,7 @@ testNotificationSubscription (ATransport t) =
|
||||||
notifierId `shouldBe` nId
|
notifierId `shouldBe` nId
|
||||||
send' APNSRespOk
|
send' APNSRespOk
|
||||||
-- receive message
|
-- receive message
|
||||||
Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet rh
|
Resp "" _ (MSG RcvMessage {msgId = mId1, msgBody = EncRcvMsgBody body}) <- tGet1 rh
|
||||||
Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
|
Right ClientRcvMsgBody {msgTs = mTs, msgBody} <- pure $ parseAll clientRcvMsgBodyP =<< first show (C.cbDecrypt rcvDhSecret (C.cbNonce mId1) body)
|
||||||
mId1 `shouldBe` msgId
|
mId1 `shouldBe` msgId
|
||||||
mTs `shouldBe` msgTs
|
mTs `shouldBe` msgTs
|
||||||
|
|
|
@ -158,6 +158,9 @@ smpAgentTest1_1_1 test' =
|
||||||
testSMPServer :: SMPServer
|
testSMPServer :: SMPServer
|
||||||
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
|
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
|
||||||
|
|
||||||
|
testSMPServer2 :: SMPServer
|
||||||
|
testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5002"
|
||||||
|
|
||||||
initAgentServers :: InitialAgentServers
|
initAgentServers :: InitialAgentServers
|
||||||
initAgentServers =
|
initAgentServers =
|
||||||
InitialAgentServers
|
InitialAgentServers
|
||||||
|
@ -165,6 +168,9 @@ initAgentServers =
|
||||||
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
|
ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
initAgentServers2 :: InitialAgentServers
|
||||||
|
initAgentServers2 = initAgentServers {smp = L.fromList [testSMPServer, testSMPServer2]}
|
||||||
|
|
||||||
agentCfg :: AgentConfig
|
agentCfg :: AgentConfig
|
||||||
agentCfg =
|
agentCfg =
|
||||||
defaultAgentConfig
|
defaultAgentConfig
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NumericUnderscores #-}
|
{-# LANGUAGE NumericUnderscores #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
@ -44,6 +45,9 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
|
||||||
testStoreLogFile :: FilePath
|
testStoreLogFile :: FilePath
|
||||||
testStoreLogFile = "tests/tmp/smp-server-store.log"
|
testStoreLogFile = "tests/tmp/smp-server-store.log"
|
||||||
|
|
||||||
|
testStoreLogFile2 :: FilePath
|
||||||
|
testStoreLogFile2 = "tests/tmp/smp-server-store.log.2"
|
||||||
|
|
||||||
testStoreMsgsFile :: FilePath
|
testStoreMsgsFile :: FilePath
|
||||||
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
|
testStoreMsgsFile = "tests/tmp/smp-server-messages.log"
|
||||||
|
|
||||||
|
@ -140,10 +144,10 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
|
||||||
where
|
where
|
||||||
tPut' h (sig, corrId, queueId, smp) = do
|
tPut' h (sig, corrId, queueId, smp) = do
|
||||||
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
|
let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp)
|
||||||
Right () <- tPut h (sig, t')
|
[Right ()] <- tPut h [(sig, t')]
|
||||||
pure ()
|
pure ()
|
||||||
tGet' h = do
|
tGet' h = do
|
||||||
(Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h
|
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
|
||||||
pure (Nothing, corrId, qId, cmd)
|
pure (Nothing, corrId, qId, cmd)
|
||||||
|
|
||||||
smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
||||||
|
|
|
@ -3,6 +3,7 @@
|
||||||
{-# LANGUAGE GADTs #-}
|
{-# LANGUAGE GADTs #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
@ -14,6 +15,7 @@ import Control.Concurrent (ThreadId, killThread, threadDelay)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception (SomeException, try)
|
import Control.Exception (SomeException, try)
|
||||||
import Control.Monad.Except (forM, forM_, runExceptT)
|
import Control.Monad.Except (forM, forM_, runExceptT)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
import Data.ByteString.Base64
|
import Data.ByteString.Base64
|
||||||
import Data.ByteString.Char8 (ByteString)
|
import Data.ByteString.Char8 (ByteString)
|
||||||
|
@ -69,15 +71,25 @@ pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
|
||||||
sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
||||||
sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
|
sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
|
||||||
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
||||||
Right () <- tPut h (sgn, t)
|
Right () <- tPut1 h (sgn, t)
|
||||||
tGet h
|
tGet1 h
|
||||||
|
|
||||||
signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
|
||||||
signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
|
signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
|
||||||
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
|
||||||
Right sig <- runExceptT $ C.sign pk t
|
Right sig <- runExceptT $ C.sign pk t
|
||||||
Right () <- tPut h (Just sig, t)
|
Right () <- tPut1 h (Just sig, t)
|
||||||
tGet h
|
tGet1 h
|
||||||
|
|
||||||
|
tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ())
|
||||||
|
tPut1 h t = do
|
||||||
|
[r] <- tPut h [t]
|
||||||
|
pure r
|
||||||
|
|
||||||
|
tGet1 :: (ProtocolEncoding cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission cmd)
|
||||||
|
tGet1 h = do
|
||||||
|
[r] <- tGet h
|
||||||
|
pure r
|
||||||
|
|
||||||
(#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
|
(#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion
|
||||||
(actual, expected) #== message = assertEqual message expected actual
|
(actual, expected) #== message = assertEqual message expected actual
|
||||||
|
@ -110,7 +122,7 @@ testCreateSecureV2 _ =
|
||||||
(ok1, OK) #== "accepts unsigned SEND"
|
(ok1, OK) #== "accepts unsigned SEND"
|
||||||
(sId1, sId) #== "same queue ID in response 1"
|
(sId1, sId) #== "same queue ID in response 1"
|
||||||
|
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet h
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
||||||
(dec mId1 msg1, Right "hello") #== "delivers message"
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
||||||
|
|
||||||
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
||||||
|
@ -140,7 +152,7 @@ testCreateSecureV2 _ =
|
||||||
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
||||||
(ok3, OK) #== "accepts signed SEND"
|
(ok3, OK) #== "accepts signed SEND"
|
||||||
|
|
||||||
Resp "" _ (Msg mId2 msg2) <- tGet h
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
||||||
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
||||||
|
|
||||||
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
||||||
|
@ -151,7 +163,7 @@ testCreateSecureV2 _ =
|
||||||
|
|
||||||
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
||||||
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
||||||
Resp "" _ (Msg mId3 msg3) <- tGet h
|
Resp "" _ (Msg mId3 msg3) <- tGet1 h
|
||||||
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
||||||
|
|
||||||
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
||||||
|
@ -172,7 +184,7 @@ testCreateSecure (ATransport t) =
|
||||||
(ok1, OK) #== "accepts unsigned SEND"
|
(ok1, OK) #== "accepts unsigned SEND"
|
||||||
(sId1, sId) #== "same queue ID in response 1"
|
(sId1, sId) #== "same queue ID in response 1"
|
||||||
|
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet h
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
||||||
(dec mId1 msg1, Right "hello") #== "delivers message"
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
||||||
|
|
||||||
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1)
|
||||||
|
@ -202,7 +214,7 @@ testCreateSecure (ATransport t) =
|
||||||
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again")
|
||||||
(ok3, OK) #== "accepts signed SEND"
|
(ok3, OK) #== "accepts signed SEND"
|
||||||
|
|
||||||
Resp "" _ (Msg mId2 msg2) <- tGet h
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
||||||
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
|
||||||
|
|
||||||
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2)
|
||||||
|
@ -213,7 +225,7 @@ testCreateSecure (ATransport t) =
|
||||||
|
|
||||||
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
let maxAllowedMessage = B.replicate maxMessageLength '-'
|
||||||
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage)
|
||||||
Resp "" _ (Msg mId3 msg3) <- tGet h
|
Resp "" _ (Msg mId3 msg3) <- tGet1 h
|
||||||
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
(dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size"
|
||||||
|
|
||||||
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
let biggerMessage = B.replicate (maxMessageLength + 1) '-'
|
||||||
|
@ -240,7 +252,7 @@ testCreateDelete (ATransport t) =
|
||||||
Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello 2")
|
Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, _SEND "hello 2")
|
||||||
(ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
|
(ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
|
||||||
|
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet rh
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh
|
||||||
(dec mId1 msg1, Right "hello") #== "delivers message"
|
(dec mId1 msg1, Right "hello") #== "delivers message"
|
||||||
|
|
||||||
Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)
|
Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF)
|
||||||
|
@ -296,7 +308,7 @@ stressTest (ATransport t) =
|
||||||
smpTest3 t $ \h1 h2 h3 -> do
|
smpTest3 t $ \h1 h2 h3 -> do
|
||||||
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
(rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||||
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
(dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair'
|
||||||
rIds <- forM [1 .. 50 :: Int] . const $ do
|
rIds <- forM ([1 .. 50] :: [Int]) . const $ do
|
||||||
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
|
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub)
|
||||||
pure rId
|
pure rId
|
||||||
let subscribeQueues h = forM_ rIds $ \rId -> do
|
let subscribeQueues h = forM_ rIds $ \rId -> do
|
||||||
|
@ -331,7 +343,7 @@ testDuplex (ATransport t) =
|
||||||
Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
|
Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub)
|
||||||
-- "key ..." is ad-hoc, not a part of SMP protocol
|
-- "key ..." is ad-hoc, not a part of SMP protocol
|
||||||
|
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet alice
|
Resp "" _ (Msg mId1 msg1) <- tGet1 alice
|
||||||
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId1)
|
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId1)
|
||||||
Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
|
Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
|
||||||
(bobKey, strEncode bsPub) #== "key received from Bob"
|
(bobKey, strEncode bsPub) #== "key received from Bob"
|
||||||
|
@ -344,7 +356,7 @@ testDuplex (ATransport t) =
|
||||||
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
|
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd)
|
||||||
-- "reply_id ..." is ad-hoc, not a part of SMP protocol
|
-- "reply_id ..." is ad-hoc, not a part of SMP protocol
|
||||||
|
|
||||||
Resp "" _ (Msg mId2 msg2) <- tGet alice
|
Resp "" _ (Msg mId2 msg2) <- tGet1 alice
|
||||||
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
|
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2)
|
||||||
Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
|
Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
|
||||||
(bId, encode bSnd) #== "reply queue ID received from Bob"
|
(bId, encode bSnd) #== "reply queue ID received from Bob"
|
||||||
|
@ -353,7 +365,7 @@ testDuplex (ATransport t) =
|
||||||
Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
|
Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub)
|
||||||
-- "key ..." is ad-hoc, not a part of SMP protocol
|
-- "key ..." is ad-hoc, not a part of SMP protocol
|
||||||
|
|
||||||
Resp "" _ (Msg mId3 msg3) <- tGet bob
|
Resp "" _ (Msg mId3 msg3) <- tGet1 bob
|
||||||
Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK mId3)
|
Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK mId3)
|
||||||
Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
|
Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
|
||||||
(aliceKey, strEncode asPub) #== "key received from Alice"
|
(aliceKey, strEncode asPub) #== "key received from Alice"
|
||||||
|
@ -361,13 +373,13 @@ testDuplex (ATransport t) =
|
||||||
|
|
||||||
Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
|
Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, _SEND "hi alice")
|
||||||
|
|
||||||
Resp "" _ (Msg mId4 msg4) <- tGet alice
|
Resp "" _ (Msg mId4 msg4) <- tGet1 alice
|
||||||
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK mId4)
|
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK mId4)
|
||||||
(aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
|
(aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
|
||||||
|
|
||||||
Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, _SEND "how are you bob")
|
Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, _SEND "how are you bob")
|
||||||
|
|
||||||
Resp "" _ (Msg mId5 msg5) <- tGet bob
|
Resp "" _ (Msg mId5 msg5) <- tGet1 bob
|
||||||
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
|
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
|
||||||
(bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
|
(bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
|
||||||
|
|
||||||
|
@ -384,7 +396,7 @@ testSwitchSub (ATransport t) =
|
||||||
Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, _SEND "test2, no ACK")
|
Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, _SEND "test2, no ACK")
|
||||||
(ok2, OK) #== "sent test message 2"
|
(ok2, OK) #== "sent test message 2"
|
||||||
|
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet rh1
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
|
||||||
(dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
|
(dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
|
||||||
Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
|
Resp "abcd" _ (Msg mId2 msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK mId1)
|
||||||
(dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
|
(dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
|
||||||
|
@ -393,12 +405,12 @@ testSwitchSub (ATransport t) =
|
||||||
(dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
|
(dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
|
||||||
Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
|
Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK mId2')
|
||||||
|
|
||||||
Resp "" _ end <- tGet rh1
|
Resp "" _ end <- tGet1 rh1
|
||||||
(end, END) #== "unsubscribed the 1st TCP connection"
|
(end, END) #== "unsubscribed the 1st TCP connection"
|
||||||
|
|
||||||
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, _SEND "test3")
|
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, _SEND "test3")
|
||||||
|
|
||||||
Resp "" _ (Msg mId3 msg3) <- tGet rh2
|
Resp "" _ (Msg mId3 msg3) <- tGet1 rh2
|
||||||
(dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
|
(dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
|
||||||
|
|
||||||
Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK mId3)
|
Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK mId3)
|
||||||
|
@ -441,7 +453,7 @@ testGetSubCommands t =
|
||||||
Resp "1b" _ OK <- signSendRecv sh sKey ("1b", sId, _SEND "hello 3")
|
Resp "1b" _ OK <- signSendRecv sh sKey ("1b", sId, _SEND "hello 3")
|
||||||
Resp "1c" _ OK <- signSendRecv sh sKey ("1c", sId, _SEND "hello 4")
|
Resp "1c" _ OK <- signSendRecv sh sKey ("1c", sId, _SEND "hello 4")
|
||||||
-- both get the same if not ACK'd
|
-- both get the same if not ACK'd
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet rh1
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh1
|
||||||
Resp "2" _ (Msg mId1' msg1') <- signSendRecv rh2 rKey ("2", rId, GET)
|
Resp "2" _ (Msg mId1' msg1') <- signSendRecv rh2 rKey ("2", rId, GET)
|
||||||
(dec mId1 msg1, Right "hello 1") #== "received from queue via SUB"
|
(dec mId1 msg1, Right "hello 1") #== "received from queue via SUB"
|
||||||
(dec mId1' msg1', Right "hello 1") #== "retrieved from queue with GET"
|
(dec mId1' msg1', Right "hello 1") #== "retrieved from queue with GET"
|
||||||
|
@ -503,14 +515,14 @@ testWithStoreLog at@(ATransport t) =
|
||||||
writeTVar notifierId nId
|
writeTVar notifierId nId
|
||||||
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
|
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB)
|
||||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet h
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h
|
||||||
(decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
|
(decryptMsgV3 dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
|
||||||
Resp "" _ (NMSG _ _) <- tGet h1
|
Resp "" _ (NMSG _ _) <- tGet1 h1
|
||||||
|
|
||||||
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
|
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
|
||||||
atomically $ writeTVar senderId2 sId2
|
atomically $ writeTVar senderId2 sId2
|
||||||
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
||||||
Resp "" _ (Msg mId2 msg2) <- tGet h
|
Resp "" _ (Msg mId2 msg2) <- tGet1 h
|
||||||
(decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
|
(decryptMsgV3 dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
|
||||||
|
|
||||||
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
|
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL)
|
||||||
|
@ -535,7 +547,7 @@ testWithStoreLog at@(ATransport t) =
|
||||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, _SEND' "hello")
|
||||||
Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
|
Resp "cdab" _ (Msg mId3 msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB)
|
||||||
(decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
|
(decryptMsgV3 dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
|
||||||
Resp "" _ (NMSG _ _) <- tGet h1
|
Resp "" _ (NMSG _ _) <- tGet1 h1
|
||||||
-- this queue is removed - not restored
|
-- this queue is removed - not restored
|
||||||
sId2 <- readTVarIO senderId2
|
sId2 <- readTVarIO senderId2
|
||||||
Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, _SEND "hello too")
|
||||||
|
@ -576,7 +588,7 @@ testRestoreMessages at@(ATransport t) =
|
||||||
writeTVar dhShared $ Just dh
|
writeTVar dhShared $ Just dh
|
||||||
writeTVar senderId sId
|
writeTVar senderId sId
|
||||||
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet h1
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h1
|
||||||
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
||||||
(decryptMsgV3 dh mId1 msg1, Right "hello") #== "message delivered"
|
(decryptMsgV3 dh mId1 msg1, Right "hello") #== "message delivered"
|
||||||
-- messages below are delivered after server restart
|
-- messages below are delivered after server restart
|
||||||
|
@ -645,7 +657,7 @@ testRestoreMessagesV2 at@(ATransport t) =
|
||||||
writeTVar dhShared $ Just dh
|
writeTVar dhShared $ Just dh
|
||||||
writeTVar senderId sId
|
writeTVar senderId sId
|
||||||
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello")
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet h1
|
Resp "" _ (Msg mId1 msg1) <- tGet1 h1
|
||||||
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1)
|
||||||
(decryptMsgV2 dh mId1 msg1, Right "hello") #== "message delivered"
|
(decryptMsgV2 dh mId1 msg1, Right "hello") #== "message delivered"
|
||||||
-- messages below are delivered after server restart
|
-- messages below are delivered after server restart
|
||||||
|
@ -710,14 +722,15 @@ testTiming :: ATransport -> Spec
|
||||||
testTiming (ATransport t) =
|
testTiming (ATransport t) =
|
||||||
it "should have similar time for auth error, whether queue exists or not, for all key sizes" $
|
it "should have similar time for auth error, whether queue exists or not, for all key sizes" $
|
||||||
smpTest2 t $ \rh sh ->
|
smpTest2 t $ \rh sh ->
|
||||||
mapM_
|
mapM_ (testSameTiming rh sh) timingTests
|
||||||
(testSameTiming rh sh)
|
|
||||||
[ (32, 32, 200),
|
|
||||||
(32, 57, 100),
|
|
||||||
(57, 32, 200),
|
|
||||||
(57, 57, 100)
|
|
||||||
]
|
|
||||||
where
|
where
|
||||||
|
timingTests :: [(Int, Int, Int)]
|
||||||
|
timingTests =
|
||||||
|
[ (32, 32, 200),
|
||||||
|
(32, 57, 100),
|
||||||
|
(57, 32, 200),
|
||||||
|
(57, 57, 100)
|
||||||
|
]
|
||||||
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
||||||
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
|
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True
|
||||||
testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
|
testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
|
||||||
|
@ -735,7 +748,7 @@ testTiming (ATransport t) =
|
||||||
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
|
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub)
|
||||||
|
|
||||||
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
|
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello")
|
||||||
Resp "" _ (Msg mId msg) <- tGet rh
|
Resp "" _ (Msg mId msg) <- tGet1 rh
|
||||||
(dec mId msg, Right "hello") #== "delivered from queue"
|
(dec mId msg, Right "hello") #== "delivered from queue"
|
||||||
|
|
||||||
runTimingTest sh badKey sId $ _SEND "hello"
|
runTimingTest sh badKey sId $ _SEND "hello"
|
||||||
|
@ -774,23 +787,23 @@ testMessageNotifications (ATransport t) =
|
||||||
nId' `shouldNotBe` nId
|
nId' `shouldNotBe` nId
|
||||||
Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)
|
Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB)
|
||||||
Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND' "hello")
|
Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, _SEND' "hello")
|
||||||
Resp "" _ (Msg mId1 msg1) <- tGet rh
|
Resp "" _ (Msg mId1 msg1) <- tGet1 rh
|
||||||
(dec mId1 msg1, Right "hello") #== "delivered from queue"
|
(dec mId1 msg1, Right "hello") #== "delivered from queue"
|
||||||
Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
|
Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK mId1)
|
||||||
Resp "" _ (NMSG _ _) <- tGet nh1
|
Resp "" _ (NMSG _ _) <- tGet1 nh1
|
||||||
Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
|
Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB)
|
||||||
Resp "" _ END <- tGet nh1
|
Resp "" _ END <- tGet1 nh1
|
||||||
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
|
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, _SEND' "hello again")
|
||||||
Resp "" _ (Msg mId2 msg2) <- tGet rh
|
Resp "" _ (Msg mId2 msg2) <- tGet1 rh
|
||||||
Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
|
Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
|
||||||
(dec mId2 msg2, Right "hello again") #== "delivered from queue again"
|
(dec mId2 msg2, Right "hello again") #== "delivered from queue again"
|
||||||
Resp "" _ (NMSG _ _) <- tGet nh2
|
Resp "" _ (NMSG _ _) <- tGet1 nh2
|
||||||
1000 `timeout` tGet @BrokerMsg nh1 >>= \case
|
1000 `timeout` tGet @BrokerMsg nh1 >>= \case
|
||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
|
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
|
||||||
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
|
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
|
||||||
Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
|
Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
|
||||||
Resp "" _ (Msg mId3 msg3) <- tGet rh
|
Resp "" _ (Msg mId3 msg3) <- tGet1 rh
|
||||||
(dec mId3 msg3, Right "hello there") #== "delivered from queue again"
|
(dec mId3 msg3, Right "hello there") #== "delivered from queue again"
|
||||||
1000 `timeout` tGet @BrokerMsg nh2 >>= \case
|
1000 `timeout` tGet @BrokerMsg nh2 >>= \case
|
||||||
Nothing -> pure ()
|
Nothing -> pure ()
|
||||||
|
|
Reference in New Issue