mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 16:26:02 +00:00
agent: remove protocol encodings and agent TCP server (#1189)
* rfc: remove agent protocol encodings * agent: remove protocol encodings and agent TCP server * update * remove unused code * remove * move tests * add delay to tests * stabilize test * test * more delays * reduce delays * enable all tests * delays * style
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
3dab330480
commit
3d605310ed
@@ -147,15 +147,6 @@ executables:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
smp-agent:
|
||||
source-dirs: apps/smp-agent
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- simplexmq
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
||||
xftp:
|
||||
source-dirs: apps/xftp
|
||||
main: Main.hs
|
||||
|
||||
19
rfcs/2024-06-01-agent-protocol.md
Normal file
19
rfcs/2024-06-01-agent-protocol.md
Normal file
@@ -0,0 +1,19 @@
|
||||
# Evolving agent API
|
||||
|
||||
## Problem
|
||||
|
||||
Historically, agent API started as a TCP protocol with encoding. We do not use the actual protocol and maintaining the encoding complicates the evolution of the API.
|
||||
|
||||
Currently, I was trying to add ERRS event to combine multiple subscription errors into one to prevent overloading the UI with processing multiple subscription errors (e.g.):
|
||||
|
||||
```haskell
|
||||
ERRS :: (ConnId, AgentErrorType) -> ACommand Agent AEConn
|
||||
```
|
||||
|
||||
This constructor is not possible to encode/parse in a sensible way other than including lengths of errors.
|
||||
|
||||
## Proposal
|
||||
|
||||
Remove commands type and encodings for commands and events.
|
||||
|
||||
Only keep encodings for the commands that are saved to the database: NEW, JOIN, LET, ACK, SWCH, DEL (this one is no longer used but needs to be supported for backwards compatibility).
|
||||
@@ -95,7 +95,6 @@ library
|
||||
Simplex.Messaging.Agent.Protocol
|
||||
Simplex.Messaging.Agent.QueryString
|
||||
Simplex.Messaging.Agent.RetryInterval
|
||||
Simplex.Messaging.Agent.Server
|
||||
Simplex.Messaging.Agent.Store
|
||||
Simplex.Messaging.Agent.Store.SQLite
|
||||
Simplex.Messaging.Agent.Store.SQLite.Common
|
||||
@@ -352,81 +351,6 @@ executable ntf-server
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable smp-agent
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_simplexmq
|
||||
hs-source-dirs:
|
||||
apps/smp-agent
|
||||
default-extensions:
|
||||
StrictData
|
||||
ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts
|
||||
build-depends:
|
||||
aeson ==2.2.*
|
||||
, ansi-terminal >=0.10 && <0.12
|
||||
, asn1-encoding ==0.9.*
|
||||
, asn1-types ==0.3.*
|
||||
, async ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.14 && <5
|
||||
, base64-bytestring >=1.0 && <1.3
|
||||
, case-insensitive ==1.2.*
|
||||
, composition ==1.0.*
|
||||
, constraints >=0.12 && <0.14
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, crypton-x509 ==1.7.*
|
||||
, crypton-x509-store ==1.6.*
|
||||
, crypton-x509-validation ==1.6.*
|
||||
, cryptostore ==0.3.*
|
||||
, data-default ==0.7.*
|
||||
, direct-sqlcipher ==2.3.*
|
||||
, directory ==1.3.*
|
||||
, filepath ==1.4.*
|
||||
, hourglass ==0.2.*
|
||||
, http-types ==0.12.*
|
||||
, http2 >=4.2.2 && <4.3
|
||||
, ini ==0.4.1
|
||||
, iproute ==1.7.*
|
||||
, iso8601-time ==0.1.*
|
||||
, memory ==0.18.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
, network >=3.1.2.7 && <3.2
|
||||
, network-info ==0.2.*
|
||||
, network-transport ==0.5.6
|
||||
, network-udp ==0.0.*
|
||||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq
|
||||
, socks ==0.6.*
|
||||
, sqlcipher-simple ==0.4.*
|
||||
, stm ==2.5.*
|
||||
, temporary ==1.3.*
|
||||
, time ==1.12.*
|
||||
, time-manager ==0.0.*
|
||||
, tls >=1.7.0 && <1.8
|
||||
, transformers ==0.6.*
|
||||
, unliftio ==0.2.*
|
||||
, unliftio-core ==0.2.*
|
||||
, websockets ==0.12.*
|
||||
, yaml ==0.11.*
|
||||
, zstd ==0.1.3.*
|
||||
default-language: Haskell2010
|
||||
if flag(swift)
|
||||
cpp-options: -DswiftJSON
|
||||
if impl(ghc >= 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.11.*
|
||||
, template-haskell ==2.20.*
|
||||
, text >=2.0.1 && <2.2
|
||||
if impl(ghc < 9.6.2)
|
||||
build-depends:
|
||||
bytestring ==0.10.*
|
||||
, template-haskell ==2.16.*
|
||||
, text >=1.2.3.0 && <1.3
|
||||
|
||||
executable smp-server
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
@@ -677,7 +601,6 @@ test-suite simplexmq-test
|
||||
CoreTests.CryptoFileTests
|
||||
CoreTests.CryptoTests
|
||||
CoreTests.EncodingTests
|
||||
CoreTests.ProtocolErrorTests
|
||||
CoreTests.RetryIntervalTests
|
||||
CoreTests.TRcvQueuesTests
|
||||
CoreTests.UtilTests
|
||||
|
||||
@@ -324,8 +324,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
|
||||
batchFiles :: (DB.Connection -> DBRcvFileId -> IO a) -> [RcvFile] -> AM' [Either AgentErrorType a]
|
||||
batchFiles f rcvFiles = withStoreBatch' c $ \db -> map (\RcvFile {rcvFileId} -> f db rcvFileId) rcvFiles
|
||||
|
||||
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
|
||||
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
|
||||
notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> EntityId -> AEvent e -> m ()
|
||||
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
|
||||
xftpSendFile' c userId file numRecipients = do
|
||||
|
||||
@@ -29,10 +29,7 @@
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
|
||||
module Simplex.Messaging.Agent
|
||||
( -- * queue-based SMP agent
|
||||
runAgentClient,
|
||||
|
||||
-- * SMP agent functional API
|
||||
( -- * SMP agent functional API
|
||||
AgentClient (..),
|
||||
AE,
|
||||
SubscriptionsInfo (..),
|
||||
@@ -185,7 +182,6 @@ import Simplex.RemoteControl.Client
|
||||
import Simplex.RemoteControl.Invitation
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.Mem.Weak (deRefWeak)
|
||||
import UnliftIO.Async (race_)
|
||||
import UnliftIO.Concurrent (forkFinally, forkIO, killThread, mkWeakThreadId, threadDelay)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
@@ -219,7 +215,7 @@ getSMPAgentClient_ clientId cfg initServers store backgroundMode =
|
||||
run AgentClient {subQ, acThread} name a =
|
||||
a `E.catchAny` \e -> whenM (isJust <$> readTVarIO acThread) $ do
|
||||
logError $ "Agent thread " <> name <> " crashed: " <> tshow e
|
||||
atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ CRITICAL True $ show e)
|
||||
atomically $ writeTBQueue subQ ("", "", AEvt SAEConn $ ERR $ CRITICAL True $ show e)
|
||||
|
||||
disconnectAgentClient :: AgentClient -> IO ()
|
||||
disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns, xftpAgent = xa}} = do
|
||||
@@ -573,40 +569,6 @@ logConnection c connected =
|
||||
let event = if connected then "connected to" else "disconnected from"
|
||||
in logInfo $ T.unwords ["client", tshow (clientId c), event, "Agent"]
|
||||
|
||||
-- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
|
||||
runAgentClient :: AgentClient -> AM' ()
|
||||
runAgentClient c = race_ (subscriber c) (client c)
|
||||
{-# INLINE runAgentClient #-}
|
||||
|
||||
client :: AgentClient -> AM' ()
|
||||
client c@AgentClient {rcvQ, subQ} = forever $ do
|
||||
(corrId, entId, cmd) <- atomically $ readTBQueue rcvQ
|
||||
runExceptT (processCommand c (entId, cmd))
|
||||
>>= atomically . writeTBQueue subQ . \case
|
||||
Left e -> (corrId, entId, APC SAEConn $ ERR e)
|
||||
Right (entId', resp) -> (corrId, entId', resp)
|
||||
|
||||
-- | execute any SMP agent command
|
||||
processCommand :: AgentClient -> (EntityId, APartyCmd 'Client) -> AM (EntityId, APartyCmd 'Agent)
|
||||
processCommand c (connId, APC e cmd) =
|
||||
second (APC e) <$> case cmd of
|
||||
NEW enableNtfs (ACM cMode) pqIK subMode -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing pqIK subMode
|
||||
JOIN enableNtfs (ACR _ cReq) pqEnc subMode connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo pqEnc subMode
|
||||
LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK)
|
||||
ACPT invId pqEnc ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo pqEnc SMSubscribe
|
||||
RJCT invId -> rejectContact' c connId invId $> (connId, OK)
|
||||
SUB -> subscribeConnection' c connId $> (connId, OK)
|
||||
SEND pqEnc msgFlags msgBody -> (connId,) . uncurry MID <$> sendMessage' c connId pqEnc msgFlags msgBody
|
||||
ACK msgId rcptInfo_ -> ackMessage' c connId msgId rcptInfo_ $> (connId, OK)
|
||||
SWCH -> switchConnection' c connId $> (connId, OK)
|
||||
OFF -> suspendConnection' c connId $> (connId, OK)
|
||||
DEL -> deleteConnection' c connId $> (connId, OK)
|
||||
CHK -> (connId,) . STAT <$> getConnectionServers' c connId
|
||||
where
|
||||
-- command interface does not support different users
|
||||
userId :: UserId
|
||||
userId = 1
|
||||
|
||||
createUser' :: AgentClient -> NonEmpty SMPServerWithAuth -> NonEmpty XFTPServerWithAuth -> AM UserId
|
||||
createUser' c smp xftp = do
|
||||
userId <- withStore' c createUserRecord
|
||||
@@ -623,12 +585,12 @@ deleteUser' c userId delSMPQueues = do
|
||||
where
|
||||
delUser =
|
||||
whenM (withStore' c (`deleteUserWithoutConns` userId)) . atomically $
|
||||
writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId)
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAENone $ DEL_USER userId)
|
||||
|
||||
newConnAsync :: ConnectionModeI c => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> CR.InitialKeys -> SubscriptionMode -> AM ConnId
|
||||
newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
|
||||
connId <- newConnNoQueues c userId "" enableNtfs cMode (CR.connPQEncryption pqInitKeys)
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) pqInitKeys subMode
|
||||
pure connId
|
||||
|
||||
newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
|
||||
@@ -647,7 +609,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup
|
||||
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
|
||||
cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
|
||||
connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) pqSupport subMode cInfo
|
||||
pure connId
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo _pqEncryption =
|
||||
@@ -657,7 +619,7 @@ allowConnectionAsync' :: AgentClient -> ACorrId -> ConnId -> ConfirmationId -> C
|
||||
allowConnectionAsync' c corrId connId confId ownConnInfo =
|
||||
withStore c (`getConn` connId) >>= \case
|
||||
SomeConn _ (RcvConnection _ RcvQueue {server}) ->
|
||||
enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo
|
||||
enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo
|
||||
_ -> throwE $ CMD PROHIBITED "allowConnectionAsync"
|
||||
|
||||
acceptContactAsync' :: AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
|
||||
@@ -687,7 +649,7 @@ ackMessageAsync' c corrId connId msgId rcptInfo_ = do
|
||||
RcvMsg {msgType} <- withStore c $ \db -> getRcvMsg db connId mId
|
||||
when (isJust rcptInfo_ && msgType /= AM_A_MSG_) $ throwE $ CMD PROHIBITED "ackMessageAsync: receipt not allowed"
|
||||
(RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId mId
|
||||
enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId rcptInfo_
|
||||
enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId rcptInfo_
|
||||
|
||||
deleteConnectionAsync' :: AgentClient -> Bool -> ConnId -> AM ()
|
||||
deleteConnectionAsync' c waitDelivery connId = deleteConnectionsAsync' c waitDelivery [connId]
|
||||
@@ -717,7 +679,7 @@ switchConnectionAsync' c corrId connId =
|
||||
| otherwise -> do
|
||||
when (ratchetSyncSendProhibited cData) $ throwE $ CMD PROHIBITED "switchConnectionAsync: send prohibited"
|
||||
rq1 <- withStore' c $ \db -> setRcvSwitchStatus db rq $ Just RSSwitchStarted
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH
|
||||
enqueueCommand c corrId connId Nothing $ AClientCommand SWCH
|
||||
let rqs' = updatedQs rq1 rqs
|
||||
pure . connectionStats $ DuplexConnection cData rqs' sqs
|
||||
_ -> throwE $ CMD PROHIBITED "switchConnectionAsync: not duplex"
|
||||
@@ -984,7 +946,7 @@ subscribeConnections' c connIds = do
|
||||
let actual = M.size rs
|
||||
expected = length connIds
|
||||
when (actual /= expected) . atomically $
|
||||
writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
|
||||
|
||||
resubscribeConnection' :: AgentClient -> ConnId -> AM ()
|
||||
resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId]
|
||||
@@ -1114,7 +1076,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
|
||||
where
|
||||
processCmd :: RetryInterval -> PendingCommand -> AM ()
|
||||
processCmd ri PendingCommand {cmdId, corrId, userId, connId, command} = case command of
|
||||
AClientCommand (APC _ cmd) -> case cmd of
|
||||
AClientCommand cmd -> case cmd of
|
||||
NEW enableNtfs (ACM cMode) pqEnc subMode -> noServer $ do
|
||||
usedSrvs <- newTVarIO ([] :: [SMPServer])
|
||||
tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do
|
||||
@@ -1223,8 +1185,8 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do
|
||||
tryWithLock name = tryCommand . withConnLock c connId name
|
||||
internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
|
||||
cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
|
||||
notify :: forall e. AEntityI e => ACommand 'Agent e -> AM ()
|
||||
notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd)
|
||||
notify :: forall e. AEntityI e => AEvent e -> AM ()
|
||||
notify cmd = atomically $ writeTBQueue subQ (corrId, connId, AEvt (sAEntity @e) cmd)
|
||||
-- ^ ^ ^ async command processing /
|
||||
|
||||
enqueueMessages :: AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> AM (AgentMsgId, PQEncryption)
|
||||
@@ -1460,9 +1422,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork
|
||||
delMsg = delMsgKeep False
|
||||
delMsgKeep :: Bool -> InternalId -> AM ()
|
||||
delMsgKeep keepForReceipt msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId keepForReceipt
|
||||
notify :: forall e. AEntityI e => ACommand 'Agent e -> AM ()
|
||||
notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd)
|
||||
notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> AM ()
|
||||
notify :: forall e. AEntityI e => AEvent e -> AM ()
|
||||
notify cmd = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) cmd)
|
||||
notifyDel :: AEntityI e => InternalId -> AEvent e -> AM ()
|
||||
notifyDel msgId cmd = notify cmd >> delMsg msgId
|
||||
connError msgId = notifyDel msgId . ERR . CONN
|
||||
qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE
|
||||
@@ -1663,7 +1625,7 @@ prepareDeleteConnections_ getConnections c waitDelivery connIds = do
|
||||
-- ! between completed deletions of connections, and deletions delayed due to wait for delivery (see deleteConn)
|
||||
deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
|
||||
rs' <- lift $ catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) (M.keys delRs))
|
||||
forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN)
|
||||
forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN)
|
||||
pure (errs' <> delRs, rqs, connIds')
|
||||
where
|
||||
rcvQueues :: SomeConn -> Either (Either AgentErrorType ()) [RcvQueue]
|
||||
@@ -1678,7 +1640,7 @@ deleteConnQueues c waitDelivery ntf rqs = do
|
||||
let connIds = M.keys $ M.filter isRight rs
|
||||
deliveryTimeout <- if waitDelivery then asks (Just . connDeleteDeliveryTimeout . config) else pure Nothing
|
||||
rs' <- catMaybes . rights <$> withStoreBatch' c (\db -> map (deleteConn db deliveryTimeout) connIds)
|
||||
forM_ rs' $ \cId -> notify ("", cId, APC SAEConn DEL_CONN)
|
||||
forM_ rs' $ \cId -> notify ("", cId, AEvt SAEConn DEL_CONN)
|
||||
pure rs
|
||||
where
|
||||
deleteQueueRecs :: [(RcvQueue, Either AgentErrorType ())] -> AM' [(RcvQueue, Either AgentErrorType ())]
|
||||
@@ -1698,7 +1660,7 @@ deleteConnQueues c waitDelivery ntf rqs = do
|
||||
Left e
|
||||
| temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> incRcvDeleteErrors db rq $> ((rq, r), Nothing)
|
||||
| otherwise -> deleteConnRcvQueue db rq $> ((rq, Right ()), Just (notifyRQ rq (Just e)))
|
||||
notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
|
||||
notifyRQ rq e_ = notify ("", qConnId rq, AEvt SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_)
|
||||
notify = when ntf . atomically . writeTBQueue (subQ c)
|
||||
connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ())
|
||||
connResults = M.map snd . foldl' addResult M.empty
|
||||
@@ -1735,7 +1697,7 @@ deleteConnections_ getConnections ntf waitDelivery c connIds = do
|
||||
let actual = M.size rs
|
||||
expected = length connIds
|
||||
when (actual /= expected) . atomically $
|
||||
writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected)
|
||||
|
||||
getConnectionServers' :: AgentClient -> ConnId -> AM ConnectionStats
|
||||
getConnectionServers' c connId = do
|
||||
@@ -1968,7 +1930,7 @@ sendNtfConnCommands c cmd = do
|
||||
Just (ConnData {enableNtfs}, _) ->
|
||||
when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd)
|
||||
_ ->
|
||||
atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn $ ERR $ INTERNAL "no connection data")
|
||||
atomically $ writeTBQueue (subQ c) ("", connId, AEvt SAEConn $ ERR $ INTERNAL "no connection data")
|
||||
|
||||
setNtfServers :: AgentClient -> [NtfServer] -> IO ()
|
||||
setNtfServers c = atomically . writeTVar (ntfServers c)
|
||||
@@ -2050,7 +2012,7 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
run SFERR deleteExpiredReplicasForDeletion
|
||||
liftIO $ threadDelay' int
|
||||
where
|
||||
run :: forall e. AEntityI e => (AgentErrorType -> ACommand 'Agent e) -> AM () -> AM' ()
|
||||
run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' ()
|
||||
run err a = do
|
||||
waitActive . runExceptT $ a `catchAgentError` (notify "" . err)
|
||||
step <- asks $ cleanupStepInterval . config
|
||||
@@ -2097,8 +2059,8 @@ cleanupManager c@AgentClient {subQ} = do
|
||||
deleteExpiredReplicasForDeletion = do
|
||||
rcvFilesTTL <- asks $ rcvFilesTTL . config
|
||||
withStore' c (`deleteDeletedSndChunkReplicasExpired` rcvFilesTTL)
|
||||
notify :: forall e. AEntityI e => EntityId -> ACommand 'Agent e -> AM ()
|
||||
notify entId cmd = atomically $ writeTBQueue subQ ("", entId, APC (sAEntity @e) cmd)
|
||||
notify :: forall e. AEntityI e => EntityId -> AEvent e -> AM ()
|
||||
notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
data ACKd = ACKd | ACKPending
|
||||
|
||||
@@ -2151,8 +2113,8 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
|
||||
atomically . whenM (isPendingSub connId) $ failSubscription c rq e
|
||||
lift $ notifyErr connId e
|
||||
isPendingSub connId = (&&) <$> hasPendingSubscription c connId <*> activeClientSession c tSess sessId
|
||||
notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> ACommand 'Agent e -> m ()
|
||||
notify' connId msg = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) msg)
|
||||
notify' :: forall e m. (AEntityI e, MonadIO m) => ConnId -> AEvent e -> m ()
|
||||
notify' connId msg = atomically $ writeTBQueue subQ ("", connId, AEvt (sAEntity @e) msg)
|
||||
notifyErr :: ConnId -> SMPClientError -> AM' ()
|
||||
notifyErr connId = notify' connId . ERR . protocolClientError SMP (B.unpack $ strEncode srv)
|
||||
processSMP :: forall c. RcvQueue -> Connection c -> ConnData -> BrokerMsg -> AM ()
|
||||
@@ -2343,7 +2305,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(_, srv, _), _v, sessId, ts)
|
||||
SMP.ERR e -> notify $ ERR $ SMP (B.unpack $ strEncode srv) e
|
||||
r -> unexpected r
|
||||
where
|
||||
notify :: forall e m. (AEntityI e, MonadIO m) => ACommand 'Agent e -> m ()
|
||||
notify :: forall e m. (AEntityI e, MonadIO m) => AEvent e -> m ()
|
||||
notify = notify' connId
|
||||
|
||||
prohibited :: String -> AM ()
|
||||
|
||||
@@ -273,8 +273,7 @@ type XFTPTransportSession = TransportSession FileResponse
|
||||
data AgentClient = AgentClient
|
||||
{ acThread :: TVar (Maybe (Weak ThreadId)),
|
||||
active :: TVar Bool,
|
||||
rcvQ :: TBQueue (ATransmission 'Client),
|
||||
subQ :: TBQueue (ATransmission 'Agent),
|
||||
subQ :: TBQueue ATransmission,
|
||||
msgQ :: TBQueue (ServerTransmissionBatch SMPVersion ErrorType BrokerMsg),
|
||||
smpServers :: TMap UserId (NonEmpty SMPServerWithAuth),
|
||||
smpClients :: TMap SMPTransportSession SMPClientVar,
|
||||
@@ -373,7 +372,7 @@ getAgentWorker' toW fromW name hasWork c key ws work = do
|
||||
notifyErr err = do
|
||||
let e = either ((", error: " <>) . show) (\_ -> ", no error") e_
|
||||
msg = "Worker " <> name <> " for " <> show key <> " terminated " <> show (restartCount rc) <> " times" <> e
|
||||
writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err msg)
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err msg)
|
||||
|
||||
newWorker :: AgentClient -> STM Worker
|
||||
newWorker c = do
|
||||
@@ -449,7 +448,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
|
||||
qSize = tbqSize cfg
|
||||
acThread <- newTVar Nothing
|
||||
active <- newTVar True
|
||||
rcvQ <- newTBQueue qSize
|
||||
subQ <- newTBQueue qSize
|
||||
msgQ <- newTBQueue qSize
|
||||
smpServers <- newTVar smp
|
||||
@@ -487,7 +485,6 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
|
||||
AgentClient
|
||||
{ acThread,
|
||||
active,
|
||||
rcvQ,
|
||||
subQ,
|
||||
msgQ,
|
||||
smpServers,
|
||||
@@ -586,7 +583,7 @@ instance ProtocolServerClient XFTPVersion XFTPErrorType FileResponse where
|
||||
|
||||
getSMPServerClient :: AgentClient -> SMPTransportSession -> AM SMPConnectedClient
|
||||
getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
|
||||
unlessM (readTVarIO active) . throwE $ INACTIVE
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess smpClients ts)
|
||||
>>= either newClient (waitForProtocolClient c tSess smpClients)
|
||||
@@ -597,7 +594,7 @@ getSMPServerClient c@AgentClient {active, smpClients, workerSeq} tSess = do
|
||||
|
||||
getSMPProxyClient :: AgentClient -> SMPTransportSession -> AM (SMPConnectedClient, Either AgentErrorType ProxiedRelay)
|
||||
getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq} destSess@(userId, destSrv, qId) = do
|
||||
unlessM (readTVarIO active) . throwE $ INACTIVE
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
proxySrv <- getNextServer c userId [destSrv]
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getClientVar proxySrv ts) >>= \(tSess, auth, v) ->
|
||||
@@ -633,7 +630,7 @@ getSMPProxyClient c@AgentClient {active, smpClients, smpProxiedRelays, workerSeq
|
||||
liftIO $ incClientStat c userId clnt "PROXY" "OK"
|
||||
pure $ Right sess
|
||||
Left e -> do
|
||||
liftIO $ incClientStat c userId clnt "PROXY" $ strEncode e
|
||||
liftIO $ incClientStat c userId clnt "PROXY" $ bshow e
|
||||
atomically $ do
|
||||
unless (serverHostError e) $ do
|
||||
removeSessVar rv destSrv prs
|
||||
@@ -692,8 +689,8 @@ smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess
|
||||
atomically $ mapM_ (releaseGetLock c) qs
|
||||
runReaderT (resubscribeSMPSession c tSess) env
|
||||
|
||||
notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO ()
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
|
||||
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> IO ()
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
resubscribeSMPSession :: AgentClient -> SMPTransportSession -> AM' ()
|
||||
resubscribeSMPSession c@AgentClient {smpSubWorkers, workerSeq} tSess = do
|
||||
@@ -743,12 +740,12 @@ reconnectSMPClient c tSess@(_, srv, _) qs = handleNotify $ do
|
||||
where
|
||||
handleNotify :: AM' () -> AM' ()
|
||||
handleNotify = E.handleAny $ notifySub "" . ERR . INTERNAL . show
|
||||
notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> AM' ()
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd)
|
||||
notifySub :: forall e. AEntityI e => ConnId -> AEvent e -> AM' ()
|
||||
notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, AEvt (sAEntity @e) cmd)
|
||||
|
||||
getNtfServerClient :: AgentClient -> NtfTransportSession -> AM NtfClient
|
||||
getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId, srv, _) = do
|
||||
unlessM (readTVarIO active) . throwE $ INACTIVE
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess ntfClients ts)
|
||||
>>= either
|
||||
@@ -767,12 +764,12 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId,
|
||||
clientDisconnected v client = do
|
||||
atomically $ removeSessVar v tSess ntfClients
|
||||
incClientStat c userId client "DISCONNECT" ""
|
||||
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
|
||||
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
|
||||
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
|
||||
|
||||
getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
|
||||
getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do
|
||||
unlessM (readTVarIO active) . throwE $ INACTIVE
|
||||
unlessM (readTVarIO active) $ throwE INACTIVE
|
||||
ts <- liftIO getCurrentTime
|
||||
atomically (getSessVar workerSeq tSess xftpClients ts)
|
||||
>>= either
|
||||
@@ -791,7 +788,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId
|
||||
clientDisconnected v client = do
|
||||
atomically $ removeSessVar v tSess xftpClients
|
||||
incClientStat c userId client "DISCONNECT" ""
|
||||
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
|
||||
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
|
||||
logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
|
||||
|
||||
waitForProtocolClient ::
|
||||
@@ -831,10 +828,10 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
|
||||
logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
|
||||
atomically $ putTMVar (sessionVar v) (Right client)
|
||||
liftIO $ incClientStat c userId client "CLIENT" "OK"
|
||||
atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
|
||||
atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent CONNECT client)
|
||||
pure client
|
||||
Left e -> do
|
||||
liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e
|
||||
liftIO $ incServerStat c userId srv "CLIENT" $ bshow e
|
||||
ei <- asks $ persistErrorInterval . config
|
||||
if ei == 0
|
||||
then atomically $ do
|
||||
@@ -845,11 +842,11 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
|
||||
atomically $ putTMVar (sessionVar v) (Left (e, Just ts))
|
||||
throwE e -- signal error to caller
|
||||
|
||||
hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone
|
||||
hostEvent :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> Client msg -> AEvent 'AENone
|
||||
hostEvent event = hostEvent' event . protocolClient
|
||||
{-# INLINE hostEvent #-}
|
||||
|
||||
hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> ProtoClient msg -> ACommand 'Agent 'AENone
|
||||
hostEvent' :: forall v err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) => (AProtocolType -> TransportHost -> AEvent 'AENone) -> ProtoClient msg -> AEvent 'AENone
|
||||
hostEvent' event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost
|
||||
|
||||
getClientConfig :: AgentClient -> (AgentConfig -> ProtocolClientConfig v) -> AM' (ProtocolClientConfig v)
|
||||
@@ -986,8 +983,8 @@ withClient_ c tSess@(userId, srv, _) statCmd action = do
|
||||
stat cl = liftIO . incClientStat c userId cl statCmd
|
||||
logServerError :: Client msg -> AgentErrorType -> AM a
|
||||
logServerError cl e = do
|
||||
logServer "<--" c srv "" $ strEncode e
|
||||
stat cl $ strEncode e
|
||||
logServer "<--" c srv "" $ bshow e
|
||||
stat cl $ bshow e
|
||||
throwE e
|
||||
|
||||
withProxySession :: AgentClient -> SMPTransportSession -> SMP.SenderId -> ByteString -> ((SMPConnectedClient, ProxiedRelay) -> AM a) -> AM a
|
||||
@@ -1005,8 +1002,8 @@ withProxySession c destSess@(userId, destSrv, _) entId cmdStr action = do
|
||||
proxySrv = showServer . protocolClientServer' . protocolClient
|
||||
logServerError :: SMPConnectedClient -> AgentErrorType -> AM a
|
||||
logServerError cl e = do
|
||||
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ strEncode e
|
||||
stat cl $ strEncode e
|
||||
logServer ("<-- " <> proxySrv cl <> " <") c destSrv "" $ bshow e
|
||||
stat cl $ bshow e
|
||||
throwE e
|
||||
|
||||
withLogClient_ :: ProtocolServerClient v err msg => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> AM a) -> AM a
|
||||
@@ -1719,7 +1716,7 @@ withWork c doWork getWork action =
|
||||
Left e -> notifyErr INTERNAL e
|
||||
where
|
||||
noWork = liftIO $ noWorkToDo doWork
|
||||
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ err $ show e)
|
||||
notifyErr err e = atomically $ writeTBQueue (subQ c) ("", "", AEvt SAEConn $ ERR $ err $ show e)
|
||||
|
||||
noWorkToDo :: TMVar () -> IO ()
|
||||
noWorkToDo = void . atomically . tryTakeTMVar
|
||||
@@ -1762,7 +1759,7 @@ suspendOperation c op endedAction = do
|
||||
notifySuspended :: AgentClient -> STM ()
|
||||
notifySuspended c = do
|
||||
-- unsafeIOToSTM $ putStrLn "notifySuspended"
|
||||
writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED)
|
||||
writeTBQueue (subQ c) ("", "", AEvt SAENone SUSPENDED)
|
||||
writeTVar (agentState c) ASSuspended
|
||||
|
||||
endOperation :: AgentClient -> AgentOperation -> STM () -> STM ()
|
||||
|
||||
@@ -29,7 +29,7 @@ import Data.Time (UTCTime, addUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (diffUTCTime)
|
||||
import Simplex.Messaging.Agent.Client
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..), AEvt (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..))
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Agent.Store.SQLite
|
||||
@@ -306,7 +306,7 @@ workerInternalError c connId internalErrStr = do
|
||||
|
||||
-- TODO change error
|
||||
notifyInternalError :: MonadIO m => AgentClient -> ConnId -> String -> m ()
|
||||
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr)
|
||||
notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AEvt SAEConn $ ERR $ INTERNAL internalErrStr)
|
||||
{-# INLINE notifyInternalError #-}
|
||||
|
||||
getNtfToken :: AM' (Maybe NtfToken)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,85 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Messaging.Agent.Server
|
||||
( -- * SMP agent over TCP
|
||||
runSMPAgent,
|
||||
runSMPAgentBlocking,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Logger.Simple (logInfo)
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Network.Socket (ServiceName)
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Client (newAgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, loadTLSServerParams, runTransportServer)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import UnliftIO.Async (race_)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
-- | Runs an SMP agent as a TCP service using passed configuration.
|
||||
--
|
||||
-- See a full agent executable here: https://github.com/simplex-chat/simplexmq/blob/master/apps/smp-agent/Main.hs
|
||||
runSMPAgent :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> IO ()
|
||||
runSMPAgent t cfg initServers store =
|
||||
runSMPAgentBlocking t cfg initServers store 0 =<< newEmptyTMVarIO
|
||||
|
||||
-- | Runs an SMP agent as a TCP service using passed configuration with signalling.
|
||||
--
|
||||
-- This function uses passed TMVar to signal when the server is ready to accept TCP requests (True)
|
||||
-- and when it is disconnected from the TCP socket once the server thread is killed (False).
|
||||
runSMPAgentBlocking :: ATransport -> AgentConfig -> InitialAgentServers -> SQLiteStore -> Int -> TMVar Bool -> IO ()
|
||||
runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile, certificateFile, privateKeyFile} initServers store initClientId started =
|
||||
case tcpPort of
|
||||
Just port -> newSMPAgentEnv cfg store >>= smpAgent t port
|
||||
Nothing -> E.throwIO $ userError "no agent port"
|
||||
where
|
||||
smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO ()
|
||||
smpAgent _ port env = do
|
||||
-- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile Nothing
|
||||
clientId <- newTVarIO initClientId
|
||||
runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
|
||||
putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
|
||||
cId <- atomically $ stateTVar clientId $ \i -> (i + 1, i + 1)
|
||||
c <- atomically $ newAgentClient cId initServers env
|
||||
logConnection c True
|
||||
race_ (connectClient h c) (runAgentClient c `runReaderT` env)
|
||||
`E.finally` (disconnectAgentClient c)
|
||||
|
||||
connectClient :: Transport c => c -> AgentClient -> IO ()
|
||||
connectClient h c = race_ (send h c) (receive h c)
|
||||
|
||||
receive :: forall c. Transport c => c -> AgentClient -> IO ()
|
||||
receive h c@AgentClient {rcvQ, subQ} = forever $ do
|
||||
(corrId, entId, cmdOrErr) <- tGet SClient h
|
||||
case cmdOrErr of
|
||||
Right cmd -> write rcvQ (corrId, entId, cmd)
|
||||
Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e)
|
||||
where
|
||||
write :: TBQueue (ATransmission p) -> ATransmission p -> IO ()
|
||||
write q t = do
|
||||
logClient c "-->" t
|
||||
atomically $ writeTBQueue q t
|
||||
|
||||
send :: Transport c => c -> AgentClient -> IO ()
|
||||
send h c@AgentClient {subQ} = forever $ do
|
||||
t <- atomically $ readTBQueue subQ
|
||||
tPut h t
|
||||
logClient c "<--" t
|
||||
|
||||
logClient :: AgentClient -> ByteString -> ATransmission a -> IO ()
|
||||
logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do
|
||||
logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd]
|
||||
@@ -47,7 +47,6 @@ import Simplex.Messaging.Protocol
|
||||
VersionSMPC,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
-- * Queue types
|
||||
|
||||
@@ -344,20 +343,20 @@ instance StrEncoding AgentCmdType where
|
||||
_ -> fail "bad AgentCmdType"
|
||||
|
||||
data AgentCommand
|
||||
= AClientCommand (APartyCmd 'Client)
|
||||
= AClientCommand ACommand
|
||||
| AInternalCommand InternalCommand
|
||||
|
||||
instance StrEncoding AgentCommand where
|
||||
strEncode = \case
|
||||
AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd)
|
||||
AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd)
|
||||
AInternalCommand cmd -> strEncode (ACInternal, cmd)
|
||||
strP =
|
||||
strP_ >>= \case
|
||||
ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP)
|
||||
ACClient -> AClientCommand <$> dbCommandP
|
||||
ACInternal -> AInternalCommand <$> strP
|
||||
|
||||
data AgentCommandTag
|
||||
= AClientCommandTag (APartyCmdTag 'Client)
|
||||
= AClientCommandTag ACommandTag
|
||||
| AInternalCommandTag InternalCommandTag
|
||||
deriving (Show)
|
||||
|
||||
@@ -436,7 +435,7 @@ instance StrEncoding InternalCommandTag where
|
||||
|
||||
agentCommandTag :: AgentCommand -> AgentCommandTag
|
||||
agentCommandTag = \case
|
||||
AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd
|
||||
AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd
|
||||
AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd
|
||||
|
||||
internalCmdTag :: InternalCommand -> InternalCommandTag
|
||||
|
||||
@@ -12,32 +12,12 @@ module AgentTests (agentTests) where
|
||||
|
||||
import AgentTests.ConnectionRequestTests
|
||||
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
|
||||
import AgentTests.FunctionalAPITests (functionalAPITests, inAnyOrder, pattern Msg, pattern Msg', pattern SENT)
|
||||
import AgentTests.FunctionalAPITests (functionalAPITests)
|
||||
import AgentTests.MigrationTests (migrationTests)
|
||||
import AgentTests.NotificationTests (notificationTests)
|
||||
import AgentTests.SQLiteTests (storeTests)
|
||||
import Control.Concurrent
|
||||
import Control.Monad (forM_, when)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Type.Equality
|
||||
import GHC.Stack (withFrozenCallStack)
|
||||
import Network.HTTP.Types (urlEncode)
|
||||
import SMPAgentClient
|
||||
import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
|
||||
import Simplex.Messaging.Agent.Protocol hiding (CONF, INFO, MID, REQ, SENT)
|
||||
import qualified Simplex.Messaging.Agent.Protocol as A
|
||||
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (ErrorType (..))
|
||||
import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import System.Directory (removeFile)
|
||||
import System.Timeout
|
||||
import Simplex.Messaging.Transport (ATransport (..))
|
||||
import Test.Hspec
|
||||
import Util
|
||||
|
||||
agentTests :: ATransport -> Spec
|
||||
agentTests (ATransport t) = do
|
||||
@@ -47,602 +27,3 @@ agentTests (ATransport t) = do
|
||||
describe "Notification tests" $ notificationTests (ATransport t)
|
||||
describe "SQLite store" storeTests
|
||||
describe "Migration tests" migrationTests
|
||||
describe "SMP agent protocol syntax" $ syntaxTests t
|
||||
describe "Establishing duplex connection (via agent protocol)" $ do
|
||||
skip "These tests are disabled because the agent does not work correctly with multiple connected TCP clients" $
|
||||
describe "one agent" $ do
|
||||
it "should connect via one server and one agent" $ do
|
||||
smpAgentTest2_1_1 $ testDuplexConnection t
|
||||
it "should connect via one server and one agent (random IDs)" $ do
|
||||
smpAgentTest2_1_1 $ testDuplexConnRandomIds t
|
||||
it "should connect via one server and 2 agents" $ do
|
||||
smpAgentTest2_2_1 $ testDuplexConnection t
|
||||
it "should connect via one server and 2 agents (random IDs)" $ do
|
||||
smpAgentTest2_2_1 $ testDuplexConnRandomIds t
|
||||
describe "should connect via 2 servers and 2 agents" $ do
|
||||
pqMatrix2 t smpAgentTest2_2_2 testDuplexConnection'
|
||||
describe "should connect via 2 servers and 2 agents (random IDs)" $ do
|
||||
pqMatrix2 t smpAgentTest2_2_2 testDuplexConnRandomIds'
|
||||
describe "Establishing connections via `contact connection`" $ do
|
||||
describe "should connect via contact connection with one server and 3 agents" $ do
|
||||
pqMatrix3 t smpAgentTest3 testContactConnection
|
||||
describe "should connect via contact connection with one server and 2 agents (random IDs)" $ do
|
||||
pqMatrix2NoInv t smpAgentTest2_2_1 testContactConnRandomIds
|
||||
it "should support rejecting contact request" $ do
|
||||
smpAgentTest2_2_1 $ testRejectContactRequest t
|
||||
describe "Connection subscriptions" $ do
|
||||
it "should connect via one server and one agent" $ do
|
||||
smpAgentTest3_1_1 $ testSubscription t
|
||||
it "should send notifications to client when server disconnects" $ do
|
||||
smpAgentServerTest $ testSubscrNotification t
|
||||
describe "Message delivery and server reconnection" $ do
|
||||
describe "should deliver messages after losing server connection and re-connecting" $
|
||||
pqMatrix2 t smpAgentTest2_2_2_needs_server testMsgDeliveryServerRestart
|
||||
it "should connect to the server when server goes up if it initially was down" $ do
|
||||
smpAgentTestN [] $ testServerConnectionAfterError t
|
||||
it "should deliver pending messages after agent restarting" $ do
|
||||
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
|
||||
it "should concurrently deliver messages to connections without blocking" $ do
|
||||
smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
|
||||
it "should deliver messages if one of connections has quota exceeded" $ do
|
||||
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
|
||||
it "should resume delivering messages after exceeding quota once all messages are received" $ do
|
||||
smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t
|
||||
|
||||
type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e)
|
||||
|
||||
type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e))
|
||||
|
||||
tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
|
||||
tGetAgent = tGetAgent' True
|
||||
|
||||
tGetAgent' :: forall c e. (Transport c, AEntityI e) => Bool -> c -> IO (AEntityTransmissionOrError 'Agent e)
|
||||
tGetAgent' skipErr h = do
|
||||
(corrId, connId, cmdOrErr) <- pGetAgent skipErr h
|
||||
case cmdOrErr of
|
||||
Right (APC e cmd) -> case testEquality e (sAEntity @e) of
|
||||
Just Refl -> pure (corrId, connId, Right cmd)
|
||||
_ -> error $ "unexpected command " <> show cmd
|
||||
Left err -> pure (corrId, connId, Left err)
|
||||
|
||||
pGetAgent :: forall c. Transport c => Bool -> c -> IO (ATransmissionOrError 'Agent)
|
||||
pGetAgent skipErr h = do
|
||||
(corrId, connId, cmdOrErr) <- tGet SAgent h
|
||||
case cmdOrErr of
|
||||
Right (APC _ CONNECT {}) -> pGetAgent skipErr h
|
||||
Right (APC _ DISCONNECT {}) -> pGetAgent skipErr h
|
||||
Right (APC _ (ERR (BROKER _ NETWORK))) | skipErr -> pGetAgent skipErr h
|
||||
cmd -> pure (corrId, connId, cmd)
|
||||
|
||||
-- | receive message to handle `h`
|
||||
(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
|
||||
(<#:) = tGetAgent
|
||||
|
||||
(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
|
||||
(<#:?) = pGetAgent True
|
||||
|
||||
(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone)
|
||||
(<#:.) = tGetAgent' True
|
||||
|
||||
-- | send transmission `t` to handle `h` and get response
|
||||
(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
|
||||
h #: t = tPutRaw h t >> (<#:) h
|
||||
|
||||
(#:!) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn)
|
||||
h #:! t = tPutRaw h t >> tGetAgent' False h
|
||||
|
||||
-- | action and expected response
|
||||
-- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
|
||||
(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation
|
||||
action #> (corrId, connId, cmd) = withFrozenCallStack $ action `shouldReturn` (corrId, connId, Right cmd)
|
||||
|
||||
-- | action and predicate for the response
|
||||
-- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p`
|
||||
(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
|
||||
action =#> p = withFrozenCallStack $ action >>= (`shouldSatisfy` p . correctTransmission)
|
||||
|
||||
pattern MID :: AgentMsgId -> ACommand 'Agent 'AEConn
|
||||
pattern MID msgId = A.MID msgId PQEncOn
|
||||
|
||||
correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd)
|
||||
correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of
|
||||
Right cmd -> (corrId, connId, cmd)
|
||||
Left e -> error $ show e
|
||||
|
||||
-- | receive message to handle `h` and validate that it is the expected one
|
||||
(<#) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AEConn -> Expectation
|
||||
h <# (corrId, connId, cmd) = timeout 5000000 (h <#:) `shouldReturn` Just (corrId, connId, Right cmd)
|
||||
|
||||
(<#.) :: (HasCallStack, Transport c) => c -> AEntityTransmission 'Agent 'AENone -> Expectation
|
||||
h <#. (corrId, connId, cmd) = timeout 5000000 (h <#:.) `shouldReturn` Just (corrId, connId, Right cmd)
|
||||
|
||||
-- | receive message to handle `h` and validate it using predicate `p`
|
||||
(<#=) :: (HasCallStack, Transport c) => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation
|
||||
h <#= p = timeout 5000000 (h <#:) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
|
||||
|
||||
(<#=?) :: (HasCallStack, Transport c) => c -> (ATransmission 'Agent -> Bool) -> Expectation
|
||||
h <#=? p = timeout 5000000 (h <#:?) >>= (`shouldSatisfy` p . correctTransmission . fromJust)
|
||||
|
||||
-- | test that nothing is delivered to handle `h` during 10ms
|
||||
(#:#) :: Transport c => c -> String -> Expectation
|
||||
h #:# err = tryGet `shouldReturn` ()
|
||||
where
|
||||
tryGet =
|
||||
10000 `timeout` tGetAgent h >>= \case
|
||||
Just _ -> error err
|
||||
_ -> return ()
|
||||
|
||||
type PQMatrix2 c =
|
||||
HasCallStack =>
|
||||
TProxy c ->
|
||||
(HasCallStack => (c -> c -> IO ()) -> Expectation) ->
|
||||
(HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> IO ()) ->
|
||||
Spec
|
||||
|
||||
pqMatrix2 :: PQMatrix2 c
|
||||
pqMatrix2 = pqMatrix2_ True
|
||||
|
||||
pqMatrix2NoInv :: PQMatrix2 c
|
||||
pqMatrix2NoInv = pqMatrix2_ False
|
||||
|
||||
pqMatrix2_ :: Bool -> PQMatrix2 c
|
||||
pqMatrix2_ pqInv _ smpTest test = do
|
||||
it "dh/dh handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
|
||||
it "dh/pq handshake" $ smpTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
|
||||
it "pq/dh handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
|
||||
it "pq/pq handshake" $ smpTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
|
||||
when pqInv $ do
|
||||
it "pq-inv/dh handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
|
||||
it "pq-inv/pq handshake" $ smpTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
|
||||
|
||||
pqMatrix3 ::
|
||||
HasCallStack =>
|
||||
TProxy c ->
|
||||
(HasCallStack => (c -> c -> c -> IO ()) -> Expectation) ->
|
||||
(HasCallStack => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()) ->
|
||||
Spec
|
||||
pqMatrix3 _ smpTest test = do
|
||||
it "dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
|
||||
it "dh/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
|
||||
it "dh/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
|
||||
it "dh/pq/pq" $ smpTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
|
||||
it "pq/dh/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
|
||||
it "pq/dh/pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
|
||||
it "pq/pq/dh" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
|
||||
it "pq" $ smpTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
|
||||
|
||||
testDuplexConnection :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
|
||||
testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, PQSupportOn)
|
||||
|
||||
testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
|
||||
testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
|
||||
let pq = pqConnectionMode aPQ bPQ
|
||||
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
|
||||
("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
|
||||
pqSup' `shouldBe` CR.connPQEncryption aPQ
|
||||
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
||||
bob <# ("", "alice", A.INFO bPQ "alice's connInfo")
|
||||
bob <# ("", "alice", CON pq)
|
||||
alice <# ("", "bob", CON pq)
|
||||
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
|
||||
alice #: ("3", "bob", "SEND F :hello") #> ("3", "bob", A.MID 4 pq)
|
||||
alice <# ("", "bob", SENT 4)
|
||||
bob <#= \case ("", "alice", Msg' 4 pq' "hello") -> pq == pq'; _ -> False
|
||||
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
|
||||
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", A.MID 5 pq)
|
||||
alice <# ("", "bob", SENT 5)
|
||||
bob <#= \case ("", "alice", Msg' 5 pq' "how are you?") -> pq == pq'; _ -> False
|
||||
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
|
||||
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", A.MID 6 pq)
|
||||
bob <# ("", "alice", SENT 6)
|
||||
alice <#= \case ("", "bob", Msg' 6 pq' "hello too") -> pq == pq'; _ -> False
|
||||
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
|
||||
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", A.MID 7 pq)
|
||||
bob <# ("", "alice", SENT 7)
|
||||
alice <#= \case ("", "bob", Msg' 7 pq' "message 1") -> pq == pq'; _ -> False
|
||||
alice #: ("4a", "bob", "ACK 7") #> ("4a", "bob", OK)
|
||||
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
|
||||
bob #: ("17", "alice", "SEND F 9\nmessage 3") #> ("17", "alice", A.MID 8 pq)
|
||||
bob <#= \case ("", "alice", MERR 8 (SMP _ AUTH)) -> True; _ -> False
|
||||
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
|
||||
alice #:# "nothing else should be delivered to alice"
|
||||
|
||||
testDuplexConnRandomIds :: (HasCallStack, Transport c) => TProxy c -> c -> c -> IO ()
|
||||
testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (bob, PQSupportOn)
|
||||
|
||||
testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
|
||||
testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
|
||||
let pq = pqConnectionMode aPQ bPQ
|
||||
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
|
||||
("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
|
||||
pqSup' `shouldBe` CR.connPQEncryption aPQ
|
||||
bobConn' `shouldBe` bobConn
|
||||
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
|
||||
bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo")
|
||||
bob <# ("", aliceConn, CON pq)
|
||||
alice <# ("", bobConn, CON pq)
|
||||
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq)
|
||||
alice <# ("", bobConn, SENT 4)
|
||||
bob <#= \case ("", c, Msg' 4 pq' "hello") -> c == aliceConn && pq == pq'; _ -> False
|
||||
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
|
||||
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, A.MID 5 pq)
|
||||
alice <# ("", bobConn, SENT 5)
|
||||
bob <#= \case ("", c, Msg' 5 pq' "how are you?") -> c == aliceConn && pq == pq'; _ -> False
|
||||
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
|
||||
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, A.MID 6 pq)
|
||||
bob <# ("", aliceConn, SENT 6)
|
||||
alice <#= \case ("", c, Msg' 6 pq' "hello too") -> c == bobConn && pq == pq'; _ -> False
|
||||
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
|
||||
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, A.MID 7 pq)
|
||||
bob <# ("", aliceConn, SENT 7)
|
||||
alice <#= \case ("", c, Msg' 7 pq' "message 1") -> c == bobConn && pq == pq'; _ -> False
|
||||
alice #: ("4a", bobConn, "ACK 7") #> ("4a", bobConn, OK)
|
||||
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
|
||||
bob #: ("17", aliceConn, "SEND F 9\nmessage 3") #> ("17", aliceConn, A.MID 8 pq)
|
||||
bob <#= \case ("", cId, MERR 8 (SMP _ AUTH)) -> cId == aliceConn; _ -> False
|
||||
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
|
||||
alice #:# "nothing else should be delivered to alice"
|
||||
|
||||
testContactConnection :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> (c, PQSupport) -> IO ()
|
||||
testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
|
||||
("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
abPQ = pqConnectionMode aPQ bPQ
|
||||
aPQMode = CR.connPQEncryption aPQ
|
||||
|
||||
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
|
||||
("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
|
||||
alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
||||
("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
|
||||
pqSup'' `shouldBe` bPQ
|
||||
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
|
||||
alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
|
||||
alice <# ("", "bob", CON abPQ)
|
||||
bob <# ("", "alice", CON abPQ)
|
||||
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ)
|
||||
alice <# ("", "bob", SENT 4)
|
||||
bob <#= \case ("", "alice", Msg' 4 pq' "hi") -> pq' == abPQ; _ -> False
|
||||
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
|
||||
|
||||
let atPQ = pqConnectionMode aPQ tPQ
|
||||
tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
|
||||
("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:)
|
||||
alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK)
|
||||
("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:)
|
||||
pqSup4 `shouldBe` tPQ
|
||||
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
|
||||
alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2")
|
||||
alice <# ("", "tom", CON atPQ)
|
||||
tom <# ("", "alice", CON atPQ)
|
||||
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ)
|
||||
alice <# ("", "tom", SENT 4)
|
||||
tom <#= \case ("", "alice", Msg' 4 pq' "hi there") -> pq' == atPQ; _ -> False
|
||||
tom #: ("23", "alice", "ACK 4") #> ("23", "alice", OK)
|
||||
|
||||
testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
|
||||
testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do
|
||||
let pq = pqConnectionMode aPQ bPQ
|
||||
("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
|
||||
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
|
||||
("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
|
||||
aliceContact' `shouldBe` aliceContact
|
||||
|
||||
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo")
|
||||
("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
|
||||
pqSup'' `shouldBe` bPQ
|
||||
aliceConn' `shouldBe` aliceConn
|
||||
|
||||
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
|
||||
alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
|
||||
alice <# ("", bobConn, CON pq)
|
||||
bob <# ("", aliceConn, CON pq)
|
||||
|
||||
alice #: ("3", bobConn, "SEND F :hi") #> ("3", bobConn, A.MID 4 pq)
|
||||
alice <# ("", bobConn, SENT 4)
|
||||
bob <#= \case ("", c, Msg' 4 pq' "hi") -> c == aliceConn && pq == pq'; _ -> False
|
||||
bob #: ("13", aliceConn, "ACK 4") #> ("13", aliceConn, OK)
|
||||
|
||||
testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testRejectContactRequest _ alice bob = do
|
||||
("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK)
|
||||
("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:)
|
||||
-- RJCT must use correct contact connection
|
||||
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
|
||||
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
|
||||
alice #: ("3", "bob", "ACPT " <> aInvId <> " 12\nalice's info") =#> \case ("3", "bob", ERR (A.CMD PROHIBITED _)) -> True; _ -> False
|
||||
bob #:# "nothing should be delivered to bob"
|
||||
|
||||
testSubscription :: Transport c => TProxy c -> c -> c -> c -> IO ()
|
||||
testSubscription _ alice1 alice2 bob = do
|
||||
(alice1, "alice") `connect` (bob, "bob")
|
||||
bob #: ("12", "alice", "SEND F 5\nhello") #> ("12", "alice", MID 4)
|
||||
bob <# ("", "alice", SENT 4)
|
||||
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
|
||||
alice1 #: ("1", "bob", "ACK 4") #> ("1", "bob", OK)
|
||||
bob #: ("13", "alice", "SEND F 11\nhello again") #> ("13", "alice", MID 5)
|
||||
bob <# ("", "alice", SENT 5)
|
||||
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
|
||||
alice1 #: ("2", "bob", "ACK 5") #> ("2", "bob", OK)
|
||||
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
|
||||
alice1 <# ("", "bob", END)
|
||||
bob #: ("14", "alice", "SEND F 2\nhi") #> ("14", "alice", MID 6)
|
||||
bob <# ("", "alice", SENT 6)
|
||||
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
|
||||
alice2 #: ("22", "bob", "ACK 6") #> ("22", "bob", OK)
|
||||
alice1 #:# "nothing else should be delivered to alice1"
|
||||
|
||||
testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO ()
|
||||
testSubscrNotification t (server, _) client = do
|
||||
client #: ("1", "conn1", "NEW T INV subscribe") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
|
||||
client #:# "nothing should be delivered to client before the server is killed"
|
||||
killThread server
|
||||
client <#. ("", "", DOWN testSMPServer ["conn1"])
|
||||
withSmpServer (ATransport t) $
|
||||
client <#= \case ("", "conn1", ERR (SMP _ AUTH)) -> True; _ -> False -- this new server does not have the queue
|
||||
|
||||
testMsgDeliveryServerRestart :: forall c. Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
|
||||
testMsgDeliveryServerRestart (alice, aPQ) (bob, bPQ) = do
|
||||
let pq = pqConnectionMode aPQ bPQ
|
||||
withServer $ do
|
||||
connect' (alice, "alice", aPQ) (bob, "bob", bPQ)
|
||||
bob #: ("1", "alice", "SEND F 2\nhi") #> ("1", "alice", A.MID 4 pq)
|
||||
bob <# ("", "alice", SENT 4)
|
||||
alice <#= \case ("", "bob", Msg' _ pq' "hi") -> pq == pq'; _ -> False
|
||||
alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK)
|
||||
alice #:# "nothing else delivered before the server is killed"
|
||||
|
||||
let server = SMPServer "localhost" testPort2 testKeyHash
|
||||
alice <#. ("", "", DOWN server ["bob"])
|
||||
bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", A.MID 5 pq)
|
||||
bob #:# "nothing else delivered before the server is restarted"
|
||||
alice #:# "nothing else delivered before the server is restarted"
|
||||
|
||||
withServer $ do
|
||||
bob <# ("", "alice", SENT 5)
|
||||
alice <#. ("", "", UP server ["bob"])
|
||||
alice <#= \case ("", "bob", Msg' _ pq' "hello again") -> pq == pq'; _ -> False
|
||||
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
|
||||
|
||||
removeFile testStoreLogFile
|
||||
where
|
||||
withServer test' = withSmpServerStoreLogOn (transport @c) testPort2 (const test') `shouldReturn` ()
|
||||
|
||||
testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
|
||||
testServerConnectionAfterError t _ = do
|
||||
withAgent1 $ \bob -> do
|
||||
withAgent2 $ \alice -> do
|
||||
withServer $ do
|
||||
connect (bob, "bob") (alice, "alice")
|
||||
bob <#. ("", "", DOWN server ["alice"])
|
||||
alice <#. ("", "", DOWN server ["bob"])
|
||||
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
|
||||
alice #:# "nothing else delivered before the server is restarted"
|
||||
bob #:# "nothing else delivered before the server is restarted"
|
||||
|
||||
withAgent1 $ \bob -> do
|
||||
withAgent2 $ \alice -> do
|
||||
bob #:! ("1", "alice", "SUB") =#> \case ("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
|
||||
alice #:! ("1", "bob", "SUB") =#> \case ("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT; _ -> False
|
||||
withServer $ do
|
||||
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
|
||||
alice <#=? \case ("", "bob", APC SAEConn (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False
|
||||
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
|
||||
bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
|
||||
bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK)
|
||||
alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5)
|
||||
alice <# ("", "bob", SENT 5)
|
||||
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
|
||||
|
||||
removeFile testStoreLogFile
|
||||
removeFile testDB
|
||||
removeFile testDB2
|
||||
where
|
||||
server = SMPServer "localhost" testPort2 testKeyHash
|
||||
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
||||
withAgent1 = withAgent agentTestPort testDB 0
|
||||
withAgent2 = withAgent agentTestPort2 testDB2 10
|
||||
withAgent :: String -> FilePath -> Int -> (c -> IO a) -> IO a
|
||||
withAgent agentPort agentDB initClientId = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) initClientId (pure ()) . const . testSMPAgentClientOn agentPort
|
||||
|
||||
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
|
||||
testMsgDeliveryAgentRestart t bob = do
|
||||
let server = SMPServer "localhost" testPort2 testKeyHash
|
||||
withAgent $ \alice -> do
|
||||
withServer $ do
|
||||
connect (bob, "bob") (alice, "alice")
|
||||
alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4)
|
||||
alice <# ("", "bob", SENT 4)
|
||||
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
||||
bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK)
|
||||
bob #:# "nothing else delivered before the server is down"
|
||||
|
||||
bob <#. ("", "", DOWN server ["alice"])
|
||||
alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5)
|
||||
alice #:# "nothing else delivered before the server is restarted"
|
||||
bob #:# "nothing else delivered before the server is restarted"
|
||||
|
||||
withAgent $ \alice -> do
|
||||
withServer $ do
|
||||
tPutRaw alice ("3", "bob", "SUB")
|
||||
alice <#= \case
|
||||
(corrId, "bob", cmd) ->
|
||||
(corrId == "3" && cmd == OK)
|
||||
|| (corrId == "" && cmd == SENT 5)
|
||||
_ -> False
|
||||
bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
|
||||
bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False
|
||||
bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK)
|
||||
|
||||
removeFile testStoreLogFile
|
||||
removeFile testDB
|
||||
where
|
||||
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
||||
withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) 0 (pure ()) . const . testSMPAgentClientOn agentTestPort
|
||||
|
||||
testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testConcurrentMsgDelivery _ alice bob = do
|
||||
connect (alice, "alice") (bob, "bob")
|
||||
|
||||
("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK)
|
||||
("", "bob2", Right (A.CONF _confId PQSupportOff _ "bob's connInfo")) <- (alice <#:)
|
||||
-- below commands would be needed to accept bob's connection, but alice does not
|
||||
-- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
||||
-- bob <# ("", "alice", INFO "alice's connInfo")
|
||||
-- bob <# ("", "alice", CON)
|
||||
-- alice <# ("", "bob", CON)
|
||||
|
||||
-- the first connection should not be blocked by the second one
|
||||
sendMessage (alice, "alice") (bob, "bob") "hello"
|
||||
-- alice #: ("2", "bob", "SEND F :hello") #> ("2", "bob", MID 1)
|
||||
-- alice <# ("", "bob", SENT 1)
|
||||
-- bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
||||
-- bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
|
||||
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 5)
|
||||
bob <# ("", "alice", SENT 5)
|
||||
-- if delivery is blocked it won't go further
|
||||
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
|
||||
alice #: ("3", "bob", "ACK 5") #> ("3", "bob", OK)
|
||||
|
||||
testMsgDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testMsgDeliveryQuotaExceeded _ alice bob = do
|
||||
connect (alice, "alice") (bob, "bob")
|
||||
connect (alice, "alice2") (bob, "bob2")
|
||||
forM_ [1 .. 4 :: Int] $ \i -> do
|
||||
let corrId = bshow i
|
||||
msg = "message " <> bshow i
|
||||
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
|
||||
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
|
||||
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND F :over quota")
|
||||
alice <#= \case ("", "bob", MWARN _ (SMP _ QUOTA)) -> True; _ -> False
|
||||
|
||||
alice #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
|
||||
-- if delivery is blocked it won't go further
|
||||
alice <# ("", "bob2", SENT 4)
|
||||
|
||||
testResumeDeliveryQuotaExceeded :: Transport c => TProxy c -> c -> c -> IO ()
|
||||
testResumeDeliveryQuotaExceeded _ alice bob = do
|
||||
connect (alice, "alice") (bob, "bob")
|
||||
forM_ [1 .. 4 :: Int] $ \i -> do
|
||||
let corrId = bshow i
|
||||
msg = "message " <> bshow i
|
||||
(_, "bob", Right (MID mId)) <- alice #: (corrId, "bob", "SEND F :" <> msg)
|
||||
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
|
||||
("5", "bob", Right (MID 8)) <- alice #: ("5", "bob", "SEND F :over quota")
|
||||
alice <#= \case ("", "bob", MWARN 8 (SMP _ QUOTA)) -> True; _ -> False
|
||||
alice #:# "the last message not sent yet"
|
||||
bob <#= \case ("", "alice", Msg "message 1") -> True; _ -> False
|
||||
bob #: ("1", "alice", "ACK 4") #> ("1", "alice", OK)
|
||||
alice #:# "the last message not sent"
|
||||
bob <#= \case ("", "alice", Msg "message 2") -> True; _ -> False
|
||||
bob #: ("2", "alice", "ACK 5") #> ("2", "alice", OK)
|
||||
alice #:# "the last message not sent"
|
||||
bob <#= \case ("", "alice", Msg "message 3") -> True; _ -> False
|
||||
bob #: ("3", "alice", "ACK 6") #> ("3", "alice", OK)
|
||||
alice #:# "the last message not sent"
|
||||
bob <#= \case ("", "alice", Msg "message 4") -> True; _ -> False
|
||||
bob #: ("4", "alice", "ACK 7") #> ("4", "alice", OK)
|
||||
inAnyOrder
|
||||
(tGetAgent alice)
|
||||
[ \case ("", c, Right (SENT 8)) -> c == "bob"; _ -> False,
|
||||
\case ("", c, Right QCONT) -> c == "bob"; _ -> False
|
||||
]
|
||||
bob <#= \case ("", "alice", Msg "over quota") -> True; _ -> False
|
||||
-- message 8 is skipped because of alice agent sending "QCONT" message
|
||||
bob #: ("5", "alice", "ACK 9") #> ("5", "alice", OK)
|
||||
|
||||
connect :: Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
|
||||
connect (h1, name1) (h2, name2) = connect' (h1, name1, IKPQOn) (h2, name2, PQSupportOn)
|
||||
|
||||
connect' :: forall c. Transport c => (c, ByteString, InitialKeys) -> (c, ByteString, PQSupport) -> IO ()
|
||||
connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do
|
||||
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe")
|
||||
let cReq' = strEncode cReq
|
||||
pq = pqConnectionMode pqMode1 pqMode2
|
||||
h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
|
||||
("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:)
|
||||
pqSup' `shouldBe` CR.connPQEncryption pqMode1
|
||||
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
|
||||
h2 <# ("", name1, A.INFO pqMode2 "info1")
|
||||
h2 <# ("", name1, CON pq)
|
||||
h1 <# ("", name2, CON pq)
|
||||
|
||||
pqConnectionMode :: InitialKeys -> PQSupport -> PQEncryption
|
||||
pqConnectionMode pqMode1 pqMode2 = PQEncryption $ supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
|
||||
|
||||
enableKEMStr :: PQSupport -> ByteString
|
||||
enableKEMStr PQSupportOn = " " <> strEncode PQSupportOn
|
||||
enableKEMStr _ = ""
|
||||
|
||||
pqConnModeStr :: InitialKeys -> ByteString
|
||||
pqConnModeStr (IKNoPQ PQSupportOff) = ""
|
||||
pqConnModeStr pq = " " <> strEncode pq
|
||||
|
||||
sendMessage :: Transport c => (c, ConnId) -> (c, ConnId) -> ByteString -> IO ()
|
||||
sendMessage (h1, name1) (h2, name2) msg = do
|
||||
("m1", name2', Right (MID mId)) <- h1 #: ("m1", name2, "SEND F :" <> msg)
|
||||
name2' `shouldBe` name2
|
||||
h1 <#= \case ("", n, SENT m) -> n == name2 && m == mId; _ -> False
|
||||
("", name1', Right (MSG MsgMeta {recipient = (msgId', _)} _ msg')) <- (h2 <#:)
|
||||
name1' `shouldBe` name1
|
||||
msg' `shouldBe` msg
|
||||
h2 #: ("m2", name1, "ACK " <> bshow msgId') =#> \case ("m2", n, OK) -> n == name1; _ -> False
|
||||
|
||||
-- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString)
|
||||
-- connect' h1 h2 = do
|
||||
-- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV subscribe")
|
||||
-- let cReq' = strEncode cReq
|
||||
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " subscribe 5\ninfo2")
|
||||
-- ("", _, Right (REQ connId _ "info2")) <- (h1 <#:)
|
||||
-- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False
|
||||
-- h2 <# ("", conn1, INFO "info1")
|
||||
-- h2 <# ("", conn1, CON)
|
||||
-- h1 <# ("", conn2, CON)
|
||||
-- pure (conn1, conn2)
|
||||
|
||||
sampleDhKey :: ByteString
|
||||
sampleDhKey = "MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
|
||||
|
||||
syntaxTests :: forall c. Transport c => TProxy c -> Spec
|
||||
syntaxTests t = do
|
||||
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX parseCommand")
|
||||
describe "NEW" $ do
|
||||
describe "valid" $ do
|
||||
it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
|
||||
describe "invalid" $ do
|
||||
it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX parseCommand")
|
||||
|
||||
describe "JOIN" $ do
|
||||
describe "valid" $ do
|
||||
it "using same server as in invitation" $
|
||||
( "311",
|
||||
"a",
|
||||
"JOIN T https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
|
||||
<> urlEncode True "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
|
||||
<> "%40localhost%3A5001%2F3456-w%3D%3D%23"
|
||||
<> urlEncode True sampleDhKey
|
||||
<> "&v=2"
|
||||
<> "&e2e=v%3D2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
|
||||
<> " subscribe "
|
||||
<> "14\nbob's connInfo"
|
||||
)
|
||||
>#> ("311", "a", "ERR SMP smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001 AUTH")
|
||||
describe "invalid" $ do
|
||||
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX parseCommand")
|
||||
where
|
||||
-- simple test for one command with the expected response
|
||||
(>#>) :: ARawTransmission -> ARawTransmission -> Expectation
|
||||
command >#> response = withFrozenCallStack $ smpAgentTest t command `shouldReturn` response
|
||||
|
||||
-- simple test for one command with a predicate for the expected response
|
||||
(>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation
|
||||
command >#>= p = withFrozenCallStack $ smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd))
|
||||
|
||||
@@ -86,7 +86,7 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteS
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, authBatchCmdsNTFVersion, pattern VersionNTF)
|
||||
@@ -96,7 +96,7 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes)
|
||||
import Simplex.Messaging.Util (diffToMicroseconds)
|
||||
import Simplex.Messaging.Util (bshow, diffToMicroseconds)
|
||||
import Simplex.Messaging.Version (VersionRange (..))
|
||||
import qualified Simplex.Messaging.Version as V
|
||||
import Simplex.Messaging.Version.Internal (Version (..))
|
||||
@@ -106,7 +106,7 @@ import UnliftIO
|
||||
import Util
|
||||
import XFTPClient (testXFTPServer)
|
||||
|
||||
type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e)
|
||||
type AEntityTransmission e = (ACorrId, ConnId, AEvent e)
|
||||
|
||||
-- deriving instance Eq (ValidFileDescription p)
|
||||
|
||||
@@ -142,49 +142,52 @@ nGet c = withFrozenCallStack $ get' @'AENone c
|
||||
|
||||
get' :: forall e m. (MonadIO m, AEntityI e, HasCallStack) => AgentClient -> m (AEntityTransmission e)
|
||||
get' c = withFrozenCallStack $ do
|
||||
(corrId, connId, APC e cmd) <- pGet c
|
||||
(corrId, connId, AEvt e cmd) <- pGet c
|
||||
case testEquality e (sAEntity @e) of
|
||||
Just Refl -> pure (corrId, connId, cmd)
|
||||
_ -> error $ "unexpected command " <> show cmd
|
||||
|
||||
pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent)
|
||||
pGet c = do
|
||||
t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c)
|
||||
pGet :: forall m. MonadIO m => AgentClient -> m ATransmission
|
||||
pGet c = pGet' c True
|
||||
|
||||
pGet' :: forall m. MonadIO m => AgentClient -> Bool -> m ATransmission
|
||||
pGet' c skipWarn = do
|
||||
t@(_, _, AEvt _ cmd) <- atomically (readTBQueue $ subQ c)
|
||||
case cmd of
|
||||
CONNECT {} -> pGet c
|
||||
DISCONNECT {} -> pGet c
|
||||
ERR (BROKER _ NETWORK) -> pGet c
|
||||
MWARN {} -> pGet c
|
||||
MWARN {} | skipWarn -> pGet c
|
||||
_ -> pure t
|
||||
|
||||
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand 'Agent e
|
||||
pattern CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> AEvent e
|
||||
pattern CONF conId srvs connInfo <- A.CONF conId PQSupportOn srvs connInfo
|
||||
|
||||
pattern INFO :: ConnInfo -> ACommand 'Agent 'AEConn
|
||||
pattern INFO :: ConnInfo -> AEvent 'AEConn
|
||||
pattern INFO connInfo = A.INFO PQSupportOn connInfo
|
||||
|
||||
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand 'Agent e
|
||||
pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e
|
||||
pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo
|
||||
|
||||
pattern CON :: ACommand 'Agent 'AEConn
|
||||
pattern CON :: AEvent 'AEConn
|
||||
pattern CON = A.CON PQEncOn
|
||||
|
||||
pattern Msg :: MsgBody -> ACommand 'Agent e
|
||||
pattern Msg :: MsgBody -> AEvent e
|
||||
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk, pqEncryption = PQEncOn} _ msgBody
|
||||
|
||||
pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> ACommand 'Agent e
|
||||
pattern Msg' :: AgentMsgId -> PQEncryption -> MsgBody -> AEvent e
|
||||
pattern Msg' aMsgId pq msgBody <- MSG MsgMeta {integrity = MsgOk, recipient = (aMsgId, _), pqEncryption = pq} _ msgBody
|
||||
|
||||
pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> ACommand 'Agent 'AEConn
|
||||
pattern MsgErr :: AgentMsgId -> MsgErrorType -> MsgBody -> AEvent 'AEConn
|
||||
pattern MsgErr msgId err msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err} _ msgBody
|
||||
|
||||
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> ACommand 'Agent 'AEConn
|
||||
pattern MsgErr' :: AgentMsgId -> MsgErrorType -> PQEncryption -> MsgBody -> AEvent 'AEConn
|
||||
pattern MsgErr' msgId err pq msgBody <- MSG MsgMeta {recipient = (msgId, _), integrity = MsgError err, pqEncryption = pq} _ msgBody
|
||||
|
||||
pattern SENT :: AgentMsgId -> ACommand 'Agent 'AEConn
|
||||
pattern SENT :: AgentMsgId -> AEvent 'AEConn
|
||||
pattern SENT msgId = A.SENT msgId Nothing
|
||||
|
||||
pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn
|
||||
pattern Rcvd :: AgentMsgId -> AEvent 'AEConn
|
||||
pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
|
||||
|
||||
smpCfgVPrev :: ProtocolClientConfig SMPVersion
|
||||
@@ -242,7 +245,7 @@ runRight action =
|
||||
Right x -> pure x
|
||||
Left e -> error $ "Unexpected error: " <> show e
|
||||
|
||||
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission 'Agent -> Bool] -> Expectation
|
||||
getInAnyOrder :: HasCallStack => AgentClient -> [ATransmission -> Bool] -> Expectation
|
||||
getInAnyOrder c ts = withFrozenCallStack $ inAnyOrder (pGet c) ts
|
||||
|
||||
inAnyOrder :: (Show a, MonadUnliftIO m, HasCallStack) => m a -> [a -> Bool] -> m ()
|
||||
@@ -279,12 +282,20 @@ functionalAPITests t = do
|
||||
withSmpServer t testAgentClient3
|
||||
it "should establish connection without PQ encryption and enable it" $
|
||||
withSmpServer t testEnablePQEncryption
|
||||
describe "Establishing duplex connection, different PQ settings" $ do
|
||||
testPQMatrix2 t $ runAgentClientTestPQ True
|
||||
describe "Establishing duplex connection v2, different Ratchet versions" $
|
||||
testRatchetMatrix2 t runAgentClientTest
|
||||
describe "Establish duplex connection via contact address" $
|
||||
testMatrix2 t runAgentClientContactTest
|
||||
describe "Establish duplex connection via contact address, different PQ settings" $ do
|
||||
testPQMatrix2NoInv t $ runAgentClientContactTestPQ True PQSupportOn
|
||||
describe "Establish duplex connection via contact address v2, different Ratchet versions" $
|
||||
testRatchetMatrix2 t runAgentClientContactTest
|
||||
describe "Establish duplex connection via contact address, different PQ settings" $ do
|
||||
testPQMatrix3 t $ runAgentClientContactTestPQ3 True
|
||||
it "should support rejecting contact request" $
|
||||
withSmpServer t testRejectContactRequest
|
||||
describe "Establishing connection asynchronously" $ do
|
||||
it "should connect with initiating client going offline" $
|
||||
withSmpServer t testAsyncInitiatingOffline
|
||||
@@ -311,6 +322,10 @@ functionalAPITests t = do
|
||||
testDuplicateMessage t
|
||||
it "should report error via msg integrity on skipped messages" $
|
||||
testSkippedMessages t
|
||||
it "should connect to the server when server goes up if it initially was down" $
|
||||
testDeliveryAfterSubscriptionError t
|
||||
it "should deliver messages if one of connections has quota exceeded" $
|
||||
testMsgDeliveryQuotaExceeded t
|
||||
describe "message expiration" $ do
|
||||
it "should expire one message" $ testExpireMessage t
|
||||
it "should expire multiple messages" $ testExpireManyMessages t
|
||||
@@ -472,7 +487,7 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) =
|
||||
let v = basicAuthSMPVersion
|
||||
in allowNew && (isNothing srvAuth || (srvVersion >= v && clntVersion >= v && srvAuth == clntAuth))
|
||||
|
||||
testMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
||||
testMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
||||
testMatrix2 t runTest = do
|
||||
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
|
||||
it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
|
||||
@@ -484,7 +499,7 @@ testMatrix2 t runTest = do
|
||||
it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 $ runTest PQSupportOff False
|
||||
it "current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgVPrev 3 $ runTest PQSupportOff False
|
||||
|
||||
testRatchetMatrix2 :: ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
||||
testRatchetMatrix2 :: HasCallStack => ATransport -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
|
||||
testRatchetMatrix2 t runTest = do
|
||||
it "v8, via proxy" $ withSmpServerProxy t $ runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3 $ runTest PQSupportOn True
|
||||
it "ratchet next" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 $ runTest PQSupportOn False
|
||||
@@ -495,11 +510,50 @@ testRatchetMatrix2 t runTest = do
|
||||
it "ratchets prev to current" $ withSmpServer t $ runTestCfg2 agentCfgRatchetVPrev agentCfg 3 $ runTest PQSupportOff False
|
||||
it "ratchets current to prev" $ withSmpServer t $ runTestCfg2 agentCfg agentCfgRatchetVPrev 3 $ runTest PQSupportOff False
|
||||
|
||||
testServerMatrix2 :: ATransport -> (InitialAgentServers -> IO ()) -> Spec
|
||||
testServerMatrix2 :: HasCallStack => ATransport -> (InitialAgentServers -> IO ()) -> Spec
|
||||
testServerMatrix2 t runTest = do
|
||||
it "1 server" $ withSmpServer t $ runTest initAgentServers
|
||||
it "2 servers" $ withSmpServer t . withSmpServerOn t testPort2 $ runTest initAgentServers2
|
||||
|
||||
testPQMatrix2 :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
||||
testPQMatrix2 = pqMatrix2_ True
|
||||
|
||||
testPQMatrix2NoInv :: HasCallStack => ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
||||
testPQMatrix2NoInv = pqMatrix2_ False
|
||||
|
||||
pqMatrix2_ :: HasCallStack => Bool -> ATransport -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
|
||||
pqMatrix2_ pqInv t test = do
|
||||
it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
|
||||
it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
|
||||
it "pq/dh handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOff)
|
||||
it "pq/pq handshake" $ runTest $ \a b -> test (a, IKPQOn) (b, PQSupportOn)
|
||||
when pqInv $ do
|
||||
it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff)
|
||||
it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn)
|
||||
where
|
||||
runTest = withSmpServerProxy t . runTestCfgServers2 agentProxyCfg agentProxyCfg (initAgentServersProxy SPMAlways SPFProhibit) 3
|
||||
|
||||
testPQMatrix3 ::
|
||||
HasCallStack =>
|
||||
ATransport ->
|
||||
(HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) ->
|
||||
Spec
|
||||
testPQMatrix3 t test = do
|
||||
it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff)
|
||||
it "dh/dh/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOn)
|
||||
it "dh/pq/dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOff)
|
||||
it "dh/pq/pq" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOn) (c, PQSupportOn)
|
||||
it "pq/dh/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOff)
|
||||
it "pq/dh/pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOff) (c, PQSupportOn)
|
||||
it "pq/pq/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff)
|
||||
it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn)
|
||||
where
|
||||
runTest test' =
|
||||
withSmpServerProxy t $
|
||||
runTestCfgServers2 agentProxyCfg agentProxyCfg servers 3 $ \a b baseMsgId ->
|
||||
withAgent 3 agentProxyCfg servers testDB3 $ \c -> test' a b c baseMsgId
|
||||
servers = initAgentServersProxy SPMAlways SPFProhibit
|
||||
|
||||
runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO ()
|
||||
runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers
|
||||
{-# INLINE runTestCfg2 #-}
|
||||
@@ -509,17 +563,17 @@ runTestCfgServers2 aCfg bCfg servers baseMsgId runTest =
|
||||
withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId
|
||||
{-# INLINE runTestCfgServers2 #-}
|
||||
|
||||
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
|
||||
withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
||||
withAgentClientsCfgServers2 aCfg bCfg servers runTest =
|
||||
withAgent 1 aCfg servers testDB $ \a ->
|
||||
withAgent 2 bCfg servers testDB2 $ \b ->
|
||||
runTest a b
|
||||
|
||||
withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
|
||||
withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
||||
withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers
|
||||
{-# INLINE withAgentClientsCfg2 #-}
|
||||
|
||||
withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO ()) -> IO ()
|
||||
withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a
|
||||
withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg
|
||||
{-# INLINE withAgentClients2 #-}
|
||||
|
||||
@@ -530,16 +584,20 @@ withAgentClients3 runTest =
|
||||
runTest a b c
|
||||
|
||||
runAgentClientTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientTest pqSupport viaProxy alice@AgentClient {} bob baseId =
|
||||
runAgentClientTest pqSupport viaProxy alice bob baseId =
|
||||
runAgentClientTestPQ viaProxy (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
|
||||
|
||||
runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing (IKNoPQ pqSupport) SMSubscribe
|
||||
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
(bobId, qInfo) <- A.createConnection alice 1 True SCMInvitation Nothing aPQ SMSubscribe
|
||||
aliceId <- A.joinConnection bob 1 Nothing True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` pqSupport
|
||||
liftIO $ pqSup' `shouldBe` CR.connPQEncryption aPQ
|
||||
allowConnection alice bobId confId "alice's connInfo"
|
||||
let pqEnc = CR.pqSupportToEnc pqSupport
|
||||
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
|
||||
get alice ##> ("", bobId, A.CON pqEnc)
|
||||
get bob ##> ("", aliceId, A.INFO pqSupport "alice's connInfo")
|
||||
get bob ##> ("", aliceId, A.INFO bPQ "alice's connInfo")
|
||||
get bob ##> ("", aliceId, A.CON pqEnc)
|
||||
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
|
||||
let proxySrv = if viaProxy then Just testSMPServer else Nothing
|
||||
@@ -567,6 +625,9 @@ runAgentClientTest pqSupport viaProxy alice@AgentClient {} bob baseId =
|
||||
where
|
||||
msgId = subtract baseId . fst
|
||||
|
||||
pqConnectionMode :: InitialKeys -> PQSupport -> Bool
|
||||
pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2
|
||||
|
||||
testEnablePQEncryption :: HasCallStack => IO ()
|
||||
testEnablePQEncryption =
|
||||
withAgentClients2 $ \ca cb -> runRight_ $ do
|
||||
@@ -659,19 +720,23 @@ testAgentClient3 =
|
||||
|
||||
runAgentClientContactTest :: HasCallStack => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTest pqSupport viaProxy alice bob baseId =
|
||||
runAgentClientContactTestPQ viaProxy pqSupport (alice, IKNoPQ pqSupport) (bob, pqSupport) baseId
|
||||
|
||||
runAgentClientContactTestPQ :: HasCallStack => Bool -> PQSupport -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ viaProxy reqPQSupport (alice, aPQ) (bob, bPQ) baseId =
|
||||
runRight_ $ do
|
||||
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing (IKNoPQ pqSupport) SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo pqSupport
|
||||
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" pqSupport SMSubscribe
|
||||
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
|
||||
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" bPQ SMSubscribe
|
||||
liftIO $ aliceId' `shouldBe` aliceId
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` pqSupport
|
||||
bobId <- acceptContact alice True invId "alice's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ pqSup' `shouldBe` reqPQSupport
|
||||
bobId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
||||
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
|
||||
liftIO $ pqSup'' `shouldBe` pqSupport
|
||||
liftIO $ pqSup'' `shouldBe` bPQ
|
||||
allowConnection bob aliceId confId "bob's connInfo"
|
||||
let pqEnc = CR.pqSupportToEnc pqSupport
|
||||
get alice ##> ("", bobId, A.INFO pqSupport "bob's connInfo")
|
||||
let pqEnc = PQEncryption $ pqConnectionMode aPQ bPQ
|
||||
get alice ##> ("", bobId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
|
||||
get alice ##> ("", bobId, A.CON pqEnc)
|
||||
get bob ##> ("", aliceId, A.CON pqEnc)
|
||||
-- message IDs 1 to 3 (or 1 to 4 in v1) get assigned to control messages, so first MSG is assigned ID 4
|
||||
@@ -700,6 +765,41 @@ runAgentClientContactTest pqSupport viaProxy alice bob baseId =
|
||||
where
|
||||
msgId = subtract baseId . fst
|
||||
|
||||
runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do
|
||||
(_, qInfo) <- A.createConnection alice 1 True SCMContact Nothing aPQ SMSubscribe
|
||||
(bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo
|
||||
sentMessages abPQEnc alice bobId bob bAliceId
|
||||
(tAliceId, tomId, atPQEnc) <- connectViaContact tom tPQ qInfo
|
||||
sentMessages atPQEnc alice tomId tom tAliceId
|
||||
where
|
||||
msgId = subtract baseId . fst
|
||||
connectViaContact b pq qInfo = do
|
||||
aId <- A.prepareConnectionToJoin b 1 True qInfo pq
|
||||
aId' <- A.joinConnection b 1 (Just aId) True qInfo "bob's connInfo" pq SMSubscribe
|
||||
liftIO $ aId' `shouldBe` aId
|
||||
("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice
|
||||
liftIO $ pqSup' `shouldBe` PQSupportOn
|
||||
bId <- acceptContact alice True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
|
||||
("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
|
||||
liftIO $ pqSup'' `shouldBe` pq
|
||||
allowConnection b aId confId "bob's connInfo"
|
||||
let pqEnc = PQEncryption $ pqConnectionMode aPQ pq
|
||||
get alice ##> ("", bId, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo")
|
||||
get alice ##> ("", bId, A.CON pqEnc)
|
||||
get b ##> ("", aId, A.CON pqEnc)
|
||||
pure (aId, bId, pqEnc)
|
||||
sentMessages pqEnc a bId b aId = do
|
||||
let proxySrv = if viaProxy then Just testSMPServer else Nothing
|
||||
1 <- msgId <$> A.sendMessage a bId pqEnc SMP.noMsgFlags "hello"
|
||||
get a ##> ("", bId, A.SENT (baseId + 1) proxySrv)
|
||||
get b =##> \case ("", c, Msg' _ pq "hello") -> c == aId && pq == pqEnc; _ -> False
|
||||
ackMessage b aId (baseId + 1) Nothing
|
||||
2 <- msgId <$> A.sendMessage b aId pqEnc SMP.noMsgFlags "hello too"
|
||||
get b ##> ("", aId, A.SENT (baseId + 2) proxySrv)
|
||||
get a =##> \case ("", c, Msg' _ pq "hello too") -> c == bId && pq == pqEnc; _ -> False
|
||||
ackMessage a bId (baseId + 2) Nothing
|
||||
|
||||
noMessages :: HasCallStack => AgentClient -> String -> Expectation
|
||||
noMessages c err = tryGet `shouldReturn` ()
|
||||
where
|
||||
@@ -708,6 +808,18 @@ noMessages c err = tryGet `shouldReturn` ()
|
||||
Just msg -> error $ err <> ": " <> show msg
|
||||
_ -> return ()
|
||||
|
||||
testRejectContactRequest :: HasCallStack => IO ()
|
||||
testRejectContactRequest =
|
||||
withAgentClients2 $ \alice bob -> runRight_ $ do
|
||||
(addrConnId, qInfo) <- A.createConnection alice 1 True SCMContact Nothing IKPQOn SMSubscribe
|
||||
aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
|
||||
aliceId' <- A.joinConnection bob 1 (Just aliceId) True qInfo "bob's connInfo" PQSupportOn SMSubscribe
|
||||
liftIO $ aliceId' `shouldBe` aliceId
|
||||
("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice
|
||||
liftIO $ runExceptT (rejectContact alice "abcd" invId) `shouldReturn` Left (CONN NOT_FOUND)
|
||||
rejectContact alice addrConnId invId
|
||||
liftIO $ noMessages bob "nothing delivered to bob"
|
||||
|
||||
testAsyncInitiatingOffline :: HasCallStack => IO ()
|
||||
testAsyncInitiatingOffline =
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do
|
||||
@@ -1072,6 +1184,53 @@ testSkippedMessages t = do
|
||||
disposeAgentClient alice2
|
||||
disposeAgentClient bob2
|
||||
|
||||
testDeliveryAfterSubscriptionError :: HasCallStack => ATransport -> IO ()
|
||||
testDeliveryAfterSubscriptionError t = do
|
||||
(aId, bId) <- withAgentClients2 $ \a b -> do
|
||||
(aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ makeConnection a b
|
||||
nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId; _ -> False
|
||||
nGet b =##> \case ("", "", DOWN _ [c]) -> c == aId; _ -> False
|
||||
4 <- runRight $ sendMessage a bId SMP.noMsgFlags "hello"
|
||||
liftIO $ noMessages b "not delivered"
|
||||
pure (aId, bId)
|
||||
|
||||
withAgentClients2 $ \a b -> do
|
||||
Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection a bId
|
||||
Left (BROKER _ NETWORK) <- runExceptT $ subscribeConnection b aId
|
||||
pure ()
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
withUP a bId $ \case ("", c, SENT 4) -> c == bId; _ -> False
|
||||
withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
|
||||
ackMessage b aId 4 Nothing
|
||||
|
||||
testMsgDeliveryQuotaExceeded :: HasCallStack => ATransport -> IO ()
|
||||
testMsgDeliveryQuotaExceeded t =
|
||||
withAgentClients2 $ \a b -> withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
(aId', bId') <- makeConnection a b
|
||||
forM_ ([1 .. 4] :: [Int]) $ \i -> do
|
||||
mId <- sendMessage a bId SMP.noMsgFlags $ "message " <> bshow i
|
||||
get a =##> \case ("", c, SENT mId') -> bId == c && mId == mId'; _ -> False
|
||||
8 <- sendMessage a bId SMP.noMsgFlags "over quota"
|
||||
pGet' a False =##> \case ("", c, AEvt _ (MWARN 8 (SMP _ QUOTA))) -> bId == c; _ -> False
|
||||
4 <- sendMessage a bId' SMP.noMsgFlags "hello"
|
||||
get a =##> \case ("", c, SENT 4) -> bId' == c; _ -> False
|
||||
get b =##> \case ("", c, Msg "message 1") -> aId == c; _ -> False
|
||||
get b =##> \case ("", c, Msg "hello") -> aId' == c; _ -> False
|
||||
ackMessage b aId' 4 Nothing
|
||||
ackMessage b aId 4 Nothing
|
||||
get b =##> \case ("", c, Msg "message 2") -> aId == c; _ -> False
|
||||
ackMessage b aId 5 Nothing
|
||||
get b =##> \case ("", c, Msg "message 3") -> aId == c; _ -> False
|
||||
ackMessage b aId 6 Nothing
|
||||
get b =##> \case ("", c, Msg "message 4") -> aId == c; _ -> False
|
||||
ackMessage b aId 7 Nothing
|
||||
get a =##> \case ("", c, QCONT) -> bId == c; _ -> False
|
||||
get b =##> \case ("", c, Msg "over quota") -> aId == c; _ -> False
|
||||
ackMessage b aId 9 Nothing -- msg 8 was QCONT
|
||||
get a =##> \case ("", c, SENT 8) -> bId == c; _ -> False
|
||||
liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events")
|
||||
|
||||
testExpireMessage :: HasCallStack => ATransport -> IO ()
|
||||
testExpireMessage t =
|
||||
withAgent 1 agentCfg {messageTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
|
||||
@@ -1124,8 +1283,8 @@ withUP a bId p =
|
||||
liftIO $
|
||||
getInAnyOrder
|
||||
a
|
||||
[ \case ("", "", APC SAENone (UP _ [c])) -> c == bId; _ -> False,
|
||||
\case (corrId, c, APC SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
|
||||
[ \case ("", "", AEvt SAENone (UP _ [c])) -> c == bId; _ -> False,
|
||||
\case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
|
||||
]
|
||||
|
||||
testExpireMessageQuota :: HasCallStack => ATransport -> IO ()
|
||||
@@ -1147,8 +1306,8 @@ testExpireMessageQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1} testP
|
||||
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
|
||||
ackMessage b' aId 4 Nothing
|
||||
liftIO . getInAnyOrder a $
|
||||
[ \case ("", c, APC SAEConn (SENT 6)) -> c == bId; _ -> False,
|
||||
\case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False
|
||||
[ \case ("", c, AEvt SAEConn (SENT 6)) -> c == bId; _ -> False,
|
||||
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
|
||||
]
|
||||
get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 4) "3") -> c == aId; _ -> False
|
||||
ackMessage b' aId 6 Nothing
|
||||
@@ -1184,8 +1343,8 @@ testExpireManyMessagesQuota t = withSmpServerConfigOn t cfg {msgQueueQuota = 1}
|
||||
get b' =##> \case ("", c, Msg "1") -> c == aId; _ -> False
|
||||
ackMessage b' aId 4 Nothing
|
||||
liftIO . getInAnyOrder a $
|
||||
[ \case ("", c, APC SAEConn (SENT 8)) -> c == bId; _ -> False,
|
||||
\case ("", c, APC SAEConn QCONT) -> c == bId; _ -> False
|
||||
[ \case ("", c, AEvt SAEConn (SENT 8)) -> c == bId; _ -> False,
|
||||
\case ("", c, AEvt SAEConn QCONT) -> c == bId; _ -> False
|
||||
]
|
||||
get b' =##> \case ("", c, MsgErr 6 (MsgSkipped 4 6) "5") -> c == aId; _ -> False
|
||||
ackMessage b' aId 6 Nothing
|
||||
@@ -1258,9 +1417,9 @@ ratchetSyncP cId rss = \case
|
||||
cId' == cId && rss' == rss && ratchetSyncState == rss
|
||||
_ -> False
|
||||
|
||||
ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission 'Agent -> Bool
|
||||
ratchetSyncP' :: ConnId -> RatchetSyncState -> ATransmission -> Bool
|
||||
ratchetSyncP' cId rss = \case
|
||||
(_, cId', APC SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
|
||||
(_, cId', AEvt SAEConn (RSYNC rss' _ ConnectionStats {ratchetSyncState})) ->
|
||||
cId' == cId && rss' == rss && ratchetSyncState == rss
|
||||
_ -> False
|
||||
|
||||
@@ -1285,9 +1444,9 @@ testRatchetSyncServerOffline t = withAgentClients2 $ \alice bob -> do
|
||||
exchangeGreetingsMsgIds alice bobId 12 bob2 aliceId 9
|
||||
disposeAgentClient bob2
|
||||
|
||||
serverUpP :: ATransmission 'Agent -> Bool
|
||||
serverUpP :: ATransmission -> Bool
|
||||
serverUpP = \case
|
||||
("", "", APC SAENone (UP _ _)) -> True
|
||||
("", "", AEvt SAENone (UP _ _)) -> True
|
||||
_ -> False
|
||||
|
||||
testRatchetSyncClientRestart :: HasCallStack => ATransport -> IO ()
|
||||
@@ -1436,8 +1595,8 @@ testInactiveNoSubs t = do
|
||||
withSmpServerConfigOn t cfg' testPort $ \_ ->
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \alice -> do
|
||||
runRight_ . void $ createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate -- do not subscribe to pass noSubscriptions check
|
||||
Just (_, _, APC SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
|
||||
Just (_, _, APC SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
|
||||
Just (_, _, AEvt SAENone (CONNECT _ _)) <- timeout 2000000 $ atomically (readTBQueue $ subQ alice)
|
||||
Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
|
||||
pure ()
|
||||
|
||||
testInactiveWithSubs :: ATransport -> IO ()
|
||||
@@ -1513,13 +1672,13 @@ testSuspendingAgentCompleteSending t = withAgentClients2 $ \a b -> do
|
||||
liftIO $ suspendAgent b 5000000
|
||||
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do
|
||||
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
|
||||
pGet b =##> \case ("", c, APC SAEConn (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
|
||||
pGet b =##> \case ("", c, APC SAEConn (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False
|
||||
pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
|
||||
pGet b =##> \case ("", c, AEvt SAEConn (SENT 5)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
|
||||
pGet b =##> \case ("", c, AEvt SAEConn (SENT 6)) -> c == aId; ("", "", AEvt _ UP {}) -> True; _ -> False
|
||||
("", "", SUSPENDED) <- nGet b
|
||||
|
||||
pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
|
||||
pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False
|
||||
pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
|
||||
pGet a =##> \case ("", c, AEvt _ (Msg "hello too")) -> c == bId; ("", "", AEvt _ UP {}) -> True; _ -> False
|
||||
ackMessage a bId 5 Nothing
|
||||
get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
|
||||
ackMessage a bId 6 Nothing
|
||||
@@ -1810,8 +1969,8 @@ testWaitDelivery t =
|
||||
liftIO $
|
||||
getInAnyOrder
|
||||
bob
|
||||
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
]
|
||||
ackMessage bob aliceId (baseId + 3) Nothing
|
||||
get bob =##> \case ("", c, Msg "message 1") -> c == aliceId; _ -> False
|
||||
@@ -1947,8 +2106,8 @@ testWaitDeliveryTimeout2 t =
|
||||
liftIO $
|
||||
getInAnyOrder
|
||||
bob
|
||||
[ \case ("", "", APC SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, APC SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
[ \case ("", "", AEvt SAENone (UP _ [cId])) -> cId == aliceId; _ -> False,
|
||||
\case ("", cId, AEvt SAEConn (Msg "how are you?")) -> cId == aliceId; _ -> False
|
||||
]
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
@@ -1974,10 +2133,10 @@ testJoinConnectionAsyncReplyError t = do
|
||||
get b =##> \case ("2", c, OK) -> c == aId; _ -> False
|
||||
confId <- withSmpServerStoreLogOn t testPort $ \_ -> do
|
||||
pGet a >>= \case
|
||||
("", "", APC _ (UP _ [_])) -> do
|
||||
("", "", AEvt _ (UP _ [_])) -> do
|
||||
("", _, CONF confId _ "bob's connInfo") <- get a
|
||||
pure confId
|
||||
("", _, APC _ (CONF confId _ "bob's connInfo")) -> do
|
||||
("", _, AEvt _ (CONF confId _ "bob's connInfo")) -> do
|
||||
("", "", UP _ [_]) <- nGet a
|
||||
pure confId
|
||||
r -> error $ "unexpected response " <> show r
|
||||
@@ -1988,8 +2147,8 @@ testJoinConnectionAsyncReplyError t = do
|
||||
ConnectionStats {rcvQueuesInfo = [RcvQueueInfo {}], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
|
||||
pure ()
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
|
||||
pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False
|
||||
pGet a =##> \case ("3", c, APC _ OK) -> c == bId; ("", "", APC _ (UP _ [c])) -> c == bId; _ -> False
|
||||
pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False
|
||||
pGet a =##> \case ("3", c, AEvt _ OK) -> c == bId; ("", "", AEvt _ (UP _ [c])) -> c == bId; _ -> False
|
||||
get a ##> ("", bId, CON)
|
||||
get b ##> ("", aId, INFO "alice's connInfo")
|
||||
get b ##> ("", aId, CON)
|
||||
@@ -2261,20 +2420,20 @@ testAbortSwitchStartedReinitiate servers = do
|
||||
withB :: (AgentClient -> IO a) -> IO a
|
||||
withB = withAgent 2 agentCfg servers testDB2
|
||||
|
||||
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission 'Agent -> Bool
|
||||
switchPhaseRcvP :: ConnId -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ATransmission -> Bool
|
||||
switchPhaseRcvP cId sphase swchStatuses = switchPhaseP cId QDRcv sphase (\stats -> rcvSwchStatuses' stats == swchStatuses)
|
||||
|
||||
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission 'Agent -> Bool
|
||||
switchPhaseSndP :: ConnId -> SwitchPhase -> [Maybe SndSwitchStatus] -> ATransmission -> Bool
|
||||
switchPhaseSndP cId sphase swchStatuses = switchPhaseP cId QDSnd sphase (\stats -> sndSwchStatuses' stats == swchStatuses)
|
||||
|
||||
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission 'Agent -> Bool
|
||||
switchPhaseP :: ConnId -> QueueDirection -> SwitchPhase -> (ConnectionStats -> Bool) -> ATransmission -> Bool
|
||||
switchPhaseP cId qd sphase statsP = \case
|
||||
(_, cId', APC SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
|
||||
(_, cId', AEvt SAEConn (SWITCH qd' sphase' stats)) -> cId' == cId && qd' == qd && sphase' == sphase && statsP stats
|
||||
_ -> False
|
||||
|
||||
errQueueNotFoundP :: ConnId -> ATransmission 'Agent -> Bool
|
||||
errQueueNotFoundP :: ConnId -> ATransmission -> Bool
|
||||
errQueueNotFoundP cId = \case
|
||||
(_, cId', APC SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
|
||||
(_, cId', AEvt SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId
|
||||
_ -> False
|
||||
|
||||
testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO ()
|
||||
|
||||
@@ -56,7 +56,7 @@ import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMes
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), withStore')
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers)
|
||||
import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, SENT)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (closeSQLiteStore, getSavedNtfToken, reopenSQLiteStore)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
@@ -161,11 +161,12 @@ testNtfMatrix t runTest = do
|
||||
it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest
|
||||
|
||||
runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO ()
|
||||
runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest =
|
||||
runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = do
|
||||
withSmpServerConfigOn t smpCfg testPort $ \_ ->
|
||||
withAPNSMockServer $ \apns ->
|
||||
withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ ->
|
||||
withAgentClientsCfg2 aCfg bCfg $ runTest apns
|
||||
threadDelay 100000
|
||||
|
||||
testNotificationToken :: APNSMockServer -> IO ()
|
||||
testNotificationToken APNSMockServer {apnsQ} = do
|
||||
@@ -345,7 +346,7 @@ testRunNTFServerTests t srv =
|
||||
testProtocolServer a 1 $ ProtoServerWithAuth srv Nothing
|
||||
|
||||
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO ()
|
||||
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do
|
||||
testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
|
||||
(bobId, aliceId, nonce, message) <- runRight $ do
|
||||
-- establish connection
|
||||
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
|
||||
@@ -376,11 +377,21 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@Agen
|
||||
-- alice client already has subscription for the connection
|
||||
Left (CMD PROHIBITED _) <- runExceptT $ getNotificationMessage alice nonce message
|
||||
|
||||
threadDelay 200000
|
||||
suspendAgent alice 0
|
||||
closeSQLiteStore store
|
||||
threadDelay 200000
|
||||
|
||||
-- aliceNtf client doesn't have subscription and is allowed to get notification message
|
||||
withAgent 3 aliceCfg initAgentServers testDB $ \aliceNtf -> runRight_ $ do
|
||||
(_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message
|
||||
pure ()
|
||||
|
||||
threadDelay 200000
|
||||
reopenSQLiteStore store
|
||||
foregroundAgent alice
|
||||
threadDelay 200000
|
||||
|
||||
runRight_ $ do
|
||||
get alice =##> \case ("", c, Msg "hello") -> c == bobId; _ -> False
|
||||
ackMessage alice bobId (baseId + 1) Nothing
|
||||
|
||||
@@ -663,7 +663,7 @@ testGetPendingServerCommand st = do
|
||||
Right (Just PendingCommand {corrId = corrId'}) <- getPendingServerCommand db (Just smpServer1)
|
||||
corrId' `shouldBe` "4"
|
||||
where
|
||||
command = AClientCommand $ APC SAEConn $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
|
||||
command = AClientCommand $ NEW True (ACM SCMInvitation) (IKNoPQ PQSupportOn) SMSubscribe
|
||||
corruptCmd :: DB.Connection -> ByteString -> ConnId -> IO ()
|
||||
corruptCmd db corrId connId = DB.execute db "UPDATE commands SET command = cast('bad' as blob) WHERE conn_id = ? AND corr_id = ?" (connId, corrId)
|
||||
|
||||
|
||||
@@ -1,111 +0,0 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module CoreTests.ProtocolErrorTests where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Generic.Random (genericArbitraryU)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Agent.Protocol as Agent
|
||||
import Simplex.Messaging.Client (ProxyClientError (..))
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (CommandError (..), ErrorType (..))
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), TransportError (..))
|
||||
import Simplex.RemoteControl.Types (RCErrorType (..))
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck (modifyMaxSuccess)
|
||||
import Test.QuickCheck
|
||||
|
||||
protocolErrorTests :: Spec
|
||||
protocolErrorTests = modifyMaxSuccess (const 1000) $ do
|
||||
describe "errors parsing / serializing" $ do
|
||||
it "should parse SMP protocol errors" . property . forAll possibleErrorType $ \err ->
|
||||
smpDecode (smpEncode err) == Right err
|
||||
it "should parse SMP agent errors" . property . forAll possibleAgentErrorType $ \err ->
|
||||
strDecode (strEncode err) == Right err
|
||||
where
|
||||
possibleErrorType :: Gen ErrorType
|
||||
possibleErrorType = arbitrary >>= \e -> if skipErrorType e then discard else pure e
|
||||
possibleAgentErrorType :: Gen AgentErrorType
|
||||
possibleAgentErrorType =
|
||||
arbitrary >>= \case
|
||||
BROKER srv _ | hasSpaces srv -> discard
|
||||
SMP srv e | hasSpaces srv || skipErrorType e -> discard
|
||||
NTF srv e | hasSpaces srv || skipErrorType e -> discard
|
||||
XFTP srv _ | hasSpaces srv -> discard
|
||||
Agent.PROXY pxy srv _ | hasSpaces pxy || hasSpaces srv -> discard
|
||||
Agent.PROXY _ _ (ProxyProtocolError e) | skipErrorType e -> discard
|
||||
Agent.PROXY _ _ (ProxyUnexpectedResponse e) | hasUnicode e -> discard
|
||||
Agent.PROXY _ _ (ProxyResponseError e) | skipErrorType e -> discard
|
||||
ok -> pure ok
|
||||
hasSpaces :: String -> Bool
|
||||
hasSpaces = any (== ' ')
|
||||
hasUnicode :: String -> Bool
|
||||
hasUnicode = any (>= '\255')
|
||||
skipErrorType = \case
|
||||
SMP.PROXY (SMP.PROTOCOL e) -> skipErrorType e
|
||||
SMP.PROXY (SMP.BROKER (UNEXPECTED s)) -> hasUnicode s
|
||||
SMP.PROXY (SMP.BROKER (RESPONSE s)) -> hasUnicode s
|
||||
_ -> False
|
||||
|
||||
deriving instance Generic AgentErrorType
|
||||
|
||||
deriving instance Generic CommandErrorType
|
||||
|
||||
deriving instance Generic ConnectionErrorType
|
||||
|
||||
deriving instance Generic ProxyClientError
|
||||
|
||||
deriving instance Generic BrokerErrorType
|
||||
|
||||
deriving instance Generic SMPAgentError
|
||||
|
||||
deriving instance Generic AgentCryptoError
|
||||
|
||||
deriving instance Generic ErrorType
|
||||
|
||||
deriving instance Generic CommandError
|
||||
|
||||
deriving instance Generic SMP.ProxyError
|
||||
|
||||
deriving instance Generic TransportError
|
||||
|
||||
deriving instance Generic HandshakeError
|
||||
|
||||
deriving instance Generic XFTPErrorType
|
||||
|
||||
deriving instance Generic RCErrorType
|
||||
|
||||
instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary CommandErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary ConnectionErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary ProxyClientError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary BrokerErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary SMPAgentError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary AgentCryptoError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary ErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary CommandError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary SMP.ProxyError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary TransportError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary HandshakeError where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU
|
||||
|
||||
instance Arbitrary RCErrorType where arbitrary = genericArbitraryU
|
||||
@@ -10,54 +10,20 @@
|
||||
|
||||
module SMPAgentClient where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Unlift
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import Network.Socket (ServiceName)
|
||||
import NtfClient (ntfTestPort)
|
||||
import SMPClient
|
||||
( proxyVRange,
|
||||
serverBracket,
|
||||
testKeyHash,
|
||||
testPort,
|
||||
testPort2,
|
||||
withSmpServer,
|
||||
withSmpServerOn,
|
||||
withSmpServerThreadOn,
|
||||
)
|
||||
import SMPClient (proxyVRange, testPort)
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig)
|
||||
import Simplex.Messaging.Client (ProtocolClientConfig (..), SMPProxyFallback, SMPProxyMode, defaultNetworkConfig, defaultSMPClientConfig)
|
||||
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client
|
||||
import Test.Hspec
|
||||
import UnliftIO.Concurrent
|
||||
import UnliftIO.Directory
|
||||
import XFTPClient (testXFTPServer)
|
||||
|
||||
agentTestHost :: NonEmpty TransportHost
|
||||
agentTestHost = "localhost"
|
||||
|
||||
agentTestPort :: ServiceName
|
||||
agentTestPort = "5010"
|
||||
|
||||
agentTestPort2 :: ServiceName
|
||||
agentTestPort2 = "5011"
|
||||
|
||||
agentTestPort3 :: ServiceName
|
||||
agentTestPort3 = "5012"
|
||||
|
||||
testDB :: FilePath
|
||||
testDB = "tests/tmp/smp-agent.test.protocol.db"
|
||||
|
||||
@@ -67,114 +33,6 @@ testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
|
||||
testDB3 :: FilePath
|
||||
testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
|
||||
|
||||
smpAgentTest :: forall c. Transport c => TProxy c -> ARawTransmission -> IO ARawTransmission
|
||||
smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h
|
||||
where
|
||||
get h = do
|
||||
t@(_, _, cmdStr) <- tGetRaw h
|
||||
case parseAll networkCommandP cmdStr of
|
||||
Right (ACmd SAgent _ CONNECT {}) -> get h
|
||||
Right (ACmd SAgent _ DISCONNECT {}) -> get h
|
||||
_ -> pure t
|
||||
|
||||
runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a
|
||||
runSmpAgentTest test = withSmpServer t . withSmpAgent t $ testSMPAgentClient test
|
||||
where
|
||||
t = transport @c
|
||||
|
||||
runSmpAgentServerTest :: forall c a. Transport c => ((ThreadId, ThreadId) -> c -> IO a) -> IO a
|
||||
runSmpAgentServerTest test =
|
||||
withSmpServerThreadOn t testPort $
|
||||
\server -> withSmpAgentThreadOn t (agentTestPort, testPort, testDB) $
|
||||
\agent -> testSMPAgentClient $ test (server, agent)
|
||||
where
|
||||
t = transport @c
|
||||
|
||||
smpAgentServerTest :: Transport c => ((ThreadId, ThreadId) -> c -> IO ()) -> Expectation
|
||||
smpAgentServerTest test' = runSmpAgentServerTest test' `shouldReturn` ()
|
||||
|
||||
runSmpAgentTestN :: forall c a. Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO a) -> IO a
|
||||
runSmpAgentTestN agents test = withSmpServer t $ run agents []
|
||||
where
|
||||
run :: [(ServiceName, ServiceName, FilePath)] -> [c] -> IO a
|
||||
run [] hs = test hs
|
||||
run (a@(p, _, _) : as) hs = withSmpAgentOn t a $ testSMPAgentClientOn p $ \h -> run as (h : hs)
|
||||
t = transport @c
|
||||
|
||||
runSmpAgentTestN_1 :: forall c a. Transport c => Int -> ([c] -> IO a) -> IO a
|
||||
runSmpAgentTestN_1 nClients test = withSmpServer t . withSmpAgent t $ run nClients []
|
||||
where
|
||||
run :: Int -> [c] -> IO a
|
||||
run 0 hs = test hs
|
||||
run n hs = testSMPAgentClient $ \h -> run (n - 1) (h : hs)
|
||||
t = transport @c
|
||||
|
||||
smpAgentTestN :: Transport c => [(ServiceName, ServiceName, FilePath)] -> ([c] -> IO ()) -> Expectation
|
||||
smpAgentTestN agents test' = runSmpAgentTestN agents test' `shouldReturn` ()
|
||||
|
||||
smpAgentTestN_1 :: Transport c => Int -> ([c] -> IO ()) -> Expectation
|
||||
smpAgentTestN_1 n test' = runSmpAgentTestN_1 n test' `shouldReturn` ()
|
||||
|
||||
smpAgentTest2_2_2 :: forall c. Transport c => (c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest2_2_2 test' =
|
||||
withSmpServerOn (transport @c) testPort2 $
|
||||
smpAgentTest2_2_2_needs_server test'
|
||||
|
||||
smpAgentTest2_2_2_needs_server :: forall c. Transport c => (c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest2_2_2_needs_server test' =
|
||||
smpAgentTestN
|
||||
[ (agentTestPort, testPort, testDB),
|
||||
(agentTestPort2, testPort2, testDB2)
|
||||
]
|
||||
_test
|
||||
where
|
||||
_test [h1, h2] = test' h1 h2
|
||||
_test _ = error "expected 2 handles"
|
||||
|
||||
smpAgentTest2_2_1 :: Transport c => (c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest2_2_1 test' =
|
||||
smpAgentTestN
|
||||
[ (agentTestPort, testPort, testDB),
|
||||
(agentTestPort2, testPort, testDB2)
|
||||
]
|
||||
_test
|
||||
where
|
||||
_test [h1, h2] = test' h1 h2
|
||||
_test _ = error "expected 2 handles"
|
||||
|
||||
smpAgentTest2_1_1 :: Transport c => (c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest2_1_1 test' = smpAgentTestN_1 2 _test
|
||||
where
|
||||
_test [h1, h2] = test' h1 h2
|
||||
_test _ = error "expected 2 handles"
|
||||
|
||||
smpAgentTest3 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest3 test' =
|
||||
smpAgentTestN
|
||||
[ (agentTestPort, testPort, testDB),
|
||||
(agentTestPort2, testPort, testDB2),
|
||||
(agentTestPort3, testPort, testDB3)
|
||||
]
|
||||
_test
|
||||
where
|
||||
_test [h1, h2, h3] = test' h1 h2 h3
|
||||
_test _ = error "expected 3 handles"
|
||||
|
||||
smpAgentTest3_1_1 :: Transport c => (c -> c -> c -> IO ()) -> Expectation
|
||||
smpAgentTest3_1_1 test' = smpAgentTestN_1 3 _test
|
||||
where
|
||||
_test [h1, h2, h3] = test' h1 h2 h3
|
||||
_test _ = error "expected 3 handles"
|
||||
|
||||
smpAgentTest1_1_1 :: forall c. Transport c => (c -> IO ()) -> Expectation
|
||||
smpAgentTest1_1_1 test' =
|
||||
smpAgentTestN
|
||||
[(agentTestPort2, testPort2, testDB2)]
|
||||
_test
|
||||
where
|
||||
_test [h] = test' h
|
||||
_test _ = error "expected 1 handle"
|
||||
|
||||
testSMPServer :: SMPServer
|
||||
testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"
|
||||
|
||||
@@ -206,7 +64,7 @@ initAgentServersProxy smpProxyMode smpProxyFallback =
|
||||
agentCfg :: AgentConfig
|
||||
agentCfg =
|
||||
defaultAgentConfig
|
||||
{ tcpPort = Just agentTestPort,
|
||||
{ tcpPort = Nothing,
|
||||
tbqSize = 4,
|
||||
-- database = testDB,
|
||||
smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig},
|
||||
@@ -232,39 +90,5 @@ fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
|
||||
fastMessageRetryInterval :: RetryInterval2
|
||||
fastMessageRetryInterval = RetryInterval2 {riFast = fastRetryInterval, riSlow = fastRetryInterval}
|
||||
|
||||
withSmpAgentThreadOn_ :: ATransport -> (ServiceName, ServiceName, FilePath) -> Int -> IO () -> (ThreadId -> IO a) -> IO a
|
||||
withSmpAgentThreadOn_ t (port', smpPort', db') initClientId afterProcess =
|
||||
let cfg' = agentCfg {tcpPort = Just port'}
|
||||
initServers' = initAgentServers {smp = userServers [ProtoServerWithAuth (SMPServer "localhost" smpPort' testKeyHash) Nothing]}
|
||||
in serverBracket
|
||||
( \started -> do
|
||||
Right st <- liftIO $ createAgentStore db' "" False MCError
|
||||
when (dbNew st) . liftIO $ withTransaction' st (`SQL.execute_` "INSERT INTO users (user_id) VALUES (1)")
|
||||
runSMPAgentBlocking t cfg' initServers' st initClientId started
|
||||
)
|
||||
afterProcess
|
||||
|
||||
userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p))
|
||||
userServers srvs = M.fromList [(1, srvs)]
|
||||
|
||||
withSmpAgentThreadOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> (ThreadId -> IO a) -> IO a
|
||||
withSmpAgentThreadOn t a@(_, _, db') = withSmpAgentThreadOn_ t a 0 $ removeFile db'
|
||||
|
||||
withSmpAgentOn :: ATransport -> (ServiceName, ServiceName, FilePath) -> IO a -> IO a
|
||||
withSmpAgentOn t (port', smpPort', db') = withSmpAgentThreadOn t (port', smpPort', db') . const
|
||||
|
||||
withSmpAgent :: ATransport -> IO a -> IO a
|
||||
withSmpAgent t = withSmpAgentOn t (agentTestPort, testPort, testDB)
|
||||
|
||||
testSMPAgentClientOn :: Transport c => ServiceName -> (c -> IO a) -> IO a
|
||||
testSMPAgentClientOn port' client = do
|
||||
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig agentTestHost
|
||||
runTransportClient defaultTransportClientConfig Nothing useHost port' (Just testKeyHash) $ \h -> do
|
||||
line <- getLn h
|
||||
if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion
|
||||
then client h
|
||||
else do
|
||||
error $ "wrong welcome message: " <> B.unpack line
|
||||
|
||||
testSMPAgentClient :: Transport c => (c -> IO a) -> IO a
|
||||
testSMPAgentClient = testSMPAgentClientOn agentTestPort
|
||||
|
||||
@@ -11,7 +11,6 @@ import CoreTests.BatchingTests
|
||||
import CoreTests.CryptoFileTests
|
||||
import CoreTests.CryptoTests
|
||||
import CoreTests.EncodingTests
|
||||
import CoreTests.ProtocolErrorTests
|
||||
import CoreTests.RetryIntervalTests
|
||||
import CoreTests.TRcvQueuesTests
|
||||
import CoreTests.UtilTests
|
||||
@@ -49,7 +48,6 @@ main = do
|
||||
describe "Core tests" $ do
|
||||
describe "Batching tests" batchingTests
|
||||
describe "Encoding tests" encodingTests
|
||||
describe "Protocol error tests" protocolErrorTests
|
||||
describe "Version range" versionRangeTests
|
||||
describe "Encryption tests" cryptoTests
|
||||
describe "Encrypted files tests" cryptoFileTests
|
||||
|
||||
@@ -28,7 +28,7 @@ import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
|
||||
import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
|
||||
import Simplex.Messaging.Agent.Protocol (AEvent (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
|
||||
Reference in New Issue
Block a user