mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-04-03 17:55:55 +00:00
10c62e7fa2
* test: HELLO blocking message delivery on the same server * test: quota exceeded in one queue should not block delivery in other queues * fix test to work in stable branch * simplify pending message delivery (#202) * simplify pending message delivery (WIP) * refactor * fix concurrent message delivery * remove type synonym
439 lines
22 KiB
Haskell
439 lines
22 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE PostfixOperators #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
|
|
|
module AgentTests (agentTests) where
|
|
|
|
import AgentTests.ConnectionRequestTests
|
|
import AgentTests.FunctionalAPITests (functionalAPITests)
|
|
import AgentTests.SQLiteTests (storeTests)
|
|
import Control.Concurrent
|
|
import Control.Monad (forM_)
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import Network.HTTP.Types (urlEncode)
|
|
import SMPAgentClient
|
|
import SMPClient (testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import qualified Simplex.Messaging.Agent.Protocol as A
|
|
import Simplex.Messaging.Protocol (ErrorType (..), MsgBody)
|
|
import Simplex.Messaging.Transport (ATransport (..), TProxy (..), Transport (..))
|
|
import Simplex.Messaging.Util (bshow)
|
|
import System.Directory (removeFile)
|
|
import System.Timeout
|
|
import Test.Hspec
|
|
|
|
agentTests :: ATransport -> Spec
|
|
agentTests (ATransport t) = do
|
|
describe "Connection request" connectionRequestTests
|
|
describe "Functional API" $ functionalAPITests (ATransport t)
|
|
describe "SQLite store" storeTests
|
|
describe "SMP agent protocol syntax" $ syntaxTests t
|
|
describe "Establishing duplex connection" do
|
|
it "should connect via one server and one agent" $
|
|
smpAgentTest2_1_1 $ testDuplexConnection t
|
|
it "should connect via one server and one agent (random IDs)" $
|
|
smpAgentTest2_1_1 $ testDuplexConnRandomIds t
|
|
it "should connect via one server and 2 agents" $
|
|
smpAgentTest2_2_1 $ testDuplexConnection t
|
|
it "should connect via one server and 2 agents (random IDs)" $
|
|
smpAgentTest2_2_1 $ testDuplexConnRandomIds t
|
|
it "should connect via 2 servers and 2 agents" $
|
|
smpAgentTest2_2_2 $ testDuplexConnection t
|
|
it "should connect via 2 servers and 2 agents (random IDs)" $
|
|
smpAgentTest2_2_2 $ testDuplexConnRandomIds t
|
|
describe "Establishing connections via `contact connection`" do
|
|
it "should connect via contact connection with one server and 3 agents" $
|
|
smpAgentTest3 $ testContactConnection t
|
|
it "should connect via contact connection with one server and 2 agents (random IDs)" $
|
|
smpAgentTest2_2_1 $ testContactConnRandomIds t
|
|
it "should support rejecting contact request" $
|
|
smpAgentTest2_2_1 $ testRejectContactRequest t
|
|
describe "Connection subscriptions" do
|
|
it "should connect via one server and one agent" $
|
|
smpAgentTest3_1_1 $ testSubscription t
|
|
it "should send notifications to client when server disconnects" $
|
|
smpAgentServerTest $ testSubscrNotification t
|
|
describe "Message delivery" do
|
|
it "should deliver messages after losing server connection and re-connecting" $
|
|
smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
|
|
it "should deliver pending messages after agent restarting" $
|
|
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
|
|
it "should concurrently deliver messages to connections without blocking" $
|
|
smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
|
|
it "should deliver messages if one of connections has quota exceeded" $
|
|
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
|
|
|
|
-- | receive message to handle `h`
|
|
(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
|
|
(<#:) = tGet SAgent
|
|
|
|
-- | send transmission `t` to handle `h` and get response
|
|
(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent)
|
|
h #: t = tPutRaw h t >> (<#:) h
|
|
|
|
-- | action and expected response
|
|
-- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r`
|
|
(#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation
|
|
action #> (corrId, cAlias, cmd) = action `shouldReturn` (corrId, cAlias, 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 (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation
|
|
action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
|
|
|
|
correctTransmission :: ATransmissionOrError a -> ATransmission a
|
|
correctTransmission (corrId, cAlias, cmdOrErr) = case cmdOrErr of
|
|
Right cmd -> (corrId, cAlias, cmd)
|
|
Left e -> error $ show e
|
|
|
|
-- | receive message to handle `h` and validate that it is the expected one
|
|
(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
|
|
h <# (corrId, cAlias, cmd) = (h <#:) `shouldReturn` (corrId, cAlias, Right cmd)
|
|
|
|
-- | receive message to handle `h` and validate it using predicate `p`
|
|
(<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation
|
|
h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission)
|
|
|
|
-- | test that nothing is delivered to handle `h` during 10ms
|
|
(#:#) :: Transport c => c -> String -> Expectation
|
|
h #:# err = tryGet `shouldReturn` ()
|
|
where
|
|
tryGet =
|
|
10000 `timeout` tGet SAgent h >>= \case
|
|
Just _ -> error err
|
|
_ -> return ()
|
|
|
|
pattern Msg :: MsgBody -> ACommand 'Agent
|
|
pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} msgBody
|
|
|
|
testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO ()
|
|
testDuplexConnection _ alice bob = do
|
|
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW INV")
|
|
let cReq' = serializeConnReq cReq
|
|
bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
|
|
("", "bob", Right (CONF confId "bob's connInfo")) <- (alice <#:)
|
|
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
|
bob <# ("", "alice", INFO "alice's connInfo")
|
|
bob <# ("", "alice", CON)
|
|
alice <# ("", "bob", CON)
|
|
alice #: ("3", "bob", "SEND :hello") #> ("3", "bob", MID 1)
|
|
alice <# ("", "bob", SENT 1)
|
|
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
|
bob #: ("12", "alice", "ACK 1") #> ("12", "alice", OK)
|
|
alice #: ("4", "bob", "SEND :how are you?") #> ("4", "bob", MID 2)
|
|
alice <# ("", "bob", SENT 2)
|
|
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
|
|
bob #: ("13", "alice", "ACK 2") #> ("13", "alice", OK)
|
|
bob #: ("14", "alice", "SEND 9\nhello too") #> ("14", "alice", MID 3)
|
|
bob <# ("", "alice", SENT 3)
|
|
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
|
|
alice #: ("3a", "bob", "ACK 3") #> ("3a", "bob", OK)
|
|
bob #: ("15", "alice", "SEND 9\nmessage 1") #> ("15", "alice", MID 4)
|
|
bob <# ("", "alice", SENT 4)
|
|
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> False
|
|
alice #: ("4a", "bob", "ACK 4") #> ("4a", "bob", OK)
|
|
alice #: ("5", "bob", "OFF") #> ("5", "bob", OK)
|
|
bob #: ("17", "alice", "SEND 9\nmessage 3") #> ("17", "alice", MID 5)
|
|
bob <# ("", "alice", MERR 5 (SMP AUTH))
|
|
alice #: ("6", "bob", "DEL") #> ("6", "bob", OK)
|
|
alice #:# "nothing else should be delivered to alice"
|
|
|
|
testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
|
|
testDuplexConnRandomIds _ alice bob = do
|
|
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW INV")
|
|
let cReq' = serializeConnReq cReq
|
|
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
|
|
("", bobConn', Right (CONF confId "bob's connInfo")) <- (alice <#:)
|
|
bobConn' `shouldBe` bobConn
|
|
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
|
|
bob <# ("", aliceConn, INFO "alice's connInfo")
|
|
bob <# ("", aliceConn, CON)
|
|
alice <# ("", bobConn, CON)
|
|
alice #: ("2", bobConn, "SEND :hello") #> ("2", bobConn, MID 1)
|
|
alice <# ("", bobConn, SENT 1)
|
|
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
|
|
bob #: ("12", aliceConn, "ACK 1") #> ("12", aliceConn, OK)
|
|
alice #: ("3", bobConn, "SEND :how are you?") #> ("3", bobConn, MID 2)
|
|
alice <# ("", bobConn, SENT 2)
|
|
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
|
|
bob #: ("13", aliceConn, "ACK 2") #> ("13", aliceConn, OK)
|
|
bob #: ("14", aliceConn, "SEND 9\nhello too") #> ("14", aliceConn, MID 3)
|
|
bob <# ("", aliceConn, SENT 3)
|
|
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
|
|
alice #: ("3a", bobConn, "ACK 3") #> ("3a", bobConn, OK)
|
|
bob #: ("15", aliceConn, "SEND 9\nmessage 1") #> ("15", aliceConn, MID 4)
|
|
bob <# ("", aliceConn, SENT 4)
|
|
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> False
|
|
alice #: ("4a", bobConn, "ACK 4") #> ("4a", bobConn, OK)
|
|
alice #: ("5", bobConn, "OFF") #> ("5", bobConn, OK)
|
|
bob #: ("17", aliceConn, "SEND 9\nmessage 3") #> ("17", aliceConn, MID 5)
|
|
bob <# ("", aliceConn, MERR 5 (SMP AUTH))
|
|
alice #: ("6", bobConn, "DEL") #> ("6", bobConn, OK)
|
|
alice #:# "nothing else should be delivered to alice"
|
|
|
|
testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO ()
|
|
testContactConnection _ alice bob tom = do
|
|
("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW CON")
|
|
let cReq' = serializeConnReq cReq
|
|
|
|
bob #: ("11", "alice", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK)
|
|
("", "alice_contact", Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
|
|
alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
|
|
("", "alice", Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
|
|
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
|
|
alice <# ("", "bob", INFO "bob's connInfo 2")
|
|
alice <# ("", "bob", CON)
|
|
bob <# ("", "alice", CON)
|
|
alice #: ("3", "bob", "SEND :hi") #> ("3", "bob", MID 1)
|
|
alice <# ("", "bob", SENT 1)
|
|
bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
|
|
bob #: ("13", "alice", "ACK 1") #> ("13", "alice", OK)
|
|
|
|
tom #: ("21", "alice", "JOIN " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK)
|
|
("", "alice_contact", Right (REQ aInvId' "tom's connInfo")) <- (alice <#:)
|
|
alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK)
|
|
("", "alice", Right (CONF tConfId "alice's connInfo")) <- (tom <#:)
|
|
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
|
|
alice <# ("", "tom", INFO "tom's connInfo 2")
|
|
alice <# ("", "tom", CON)
|
|
tom <# ("", "alice", CON)
|
|
alice #: ("5", "tom", "SEND :hi there") #> ("5", "tom", MID 1)
|
|
alice <# ("", "tom", SENT 1)
|
|
tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
|
|
tom #: ("23", "alice", "ACK 1") #> ("23", "alice", OK)
|
|
|
|
testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO ()
|
|
testContactConnRandomIds _ alice bob = do
|
|
("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW CON")
|
|
let cReq' = serializeConnReq cReq
|
|
|
|
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN " <> cReq' <> " 14\nbob's connInfo")
|
|
("", aliceContact', Right (REQ aInvId "bob's connInfo")) <- (alice <#:)
|
|
aliceContact' `shouldBe` aliceContact
|
|
|
|
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> " 16\nalice's connInfo")
|
|
("", aliceConn', Right (CONF bConfId "alice's connInfo")) <- (bob <#:)
|
|
aliceConn' `shouldBe` aliceConn
|
|
|
|
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
|
|
alice <# ("", bobConn, INFO "bob's connInfo 2")
|
|
alice <# ("", bobConn, CON)
|
|
bob <# ("", aliceConn, CON)
|
|
|
|
alice #: ("3", bobConn, "SEND :hi") #> ("3", bobConn, MID 1)
|
|
alice <# ("", bobConn, SENT 1)
|
|
bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> False
|
|
bob #: ("13", aliceConn, "ACK 1") #> ("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 CON")
|
|
let cReq' = serializeConnReq cReq
|
|
bob #: ("11", "alice", "JOIN " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK)
|
|
("", "a_contact", Right (REQ aInvId "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") #> ("3", "bob", ERR $ A.CMD PROHIBITED)
|
|
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 5\nhello") #> ("12", "alice", MID 1)
|
|
bob <# ("", "alice", SENT 1)
|
|
alice1 <#= \case ("", "bob", Msg "hello") -> True; _ -> False
|
|
alice1 #: ("1", "bob", "ACK 1") #> ("1", "bob", OK)
|
|
bob #: ("13", "alice", "SEND 11\nhello again") #> ("13", "alice", MID 2)
|
|
bob <# ("", "alice", SENT 2)
|
|
alice1 <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
|
|
alice1 #: ("2", "bob", "ACK 2") #> ("2", "bob", OK)
|
|
alice2 #: ("21", "bob", "SUB") #> ("21", "bob", OK)
|
|
alice1 <# ("", "bob", END)
|
|
bob #: ("14", "alice", "SEND 2\nhi") #> ("14", "alice", MID 3)
|
|
bob <# ("", "alice", SENT 3)
|
|
alice2 <#= \case ("", "bob", Msg "hi") -> True; _ -> False
|
|
alice2 #: ("22", "bob", "ACK 3") #> ("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 INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False
|
|
client #:# "nothing should be delivered to client before the server is killed"
|
|
killThread server
|
|
client <# ("", "conn1", DOWN)
|
|
withSmpServer (ATransport t) $
|
|
client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue
|
|
|
|
testMsgDeliveryServerRestart :: Transport c => TProxy c -> c -> c -> IO ()
|
|
testMsgDeliveryServerRestart t alice bob = do
|
|
withServer $ do
|
|
connect (alice, "alice") (bob, "bob")
|
|
bob #: ("1", "alice", "SEND 2\nhi") #> ("1", "alice", MID 1)
|
|
bob <# ("", "alice", SENT 1)
|
|
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> False
|
|
alice #: ("11", "bob", "ACK 1") #> ("11", "bob", OK)
|
|
alice #:# "nothing else delivered before the server is killed"
|
|
|
|
alice <# ("", "bob", DOWN)
|
|
bob #: ("2", "alice", "SEND 11\nhello again") #> ("2", "alice", MID 2)
|
|
bob #:# "nothing else delivered before the server is restarted"
|
|
alice #:# "nothing else delivered before the server is restarted"
|
|
|
|
withServer $ do
|
|
bob <# ("", "alice", SENT 2)
|
|
alice <# ("", "bob", UP)
|
|
alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False
|
|
alice #: ("12", "bob", "ACK 2") #> ("12", "bob", OK)
|
|
|
|
removeFile testStoreLogFile
|
|
where
|
|
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
|
|
|
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
|
|
testMsgDeliveryAgentRestart t bob = do
|
|
withAgent $ \alice -> do
|
|
withServer $ do
|
|
connect (bob, "bob") (alice, "alice")
|
|
alice #: ("1", "bob", "SEND 5\nhello") #> ("1", "bob", MID 1)
|
|
alice <# ("", "bob", SENT 1)
|
|
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
|
bob #: ("11", "alice", "ACK 1") #> ("11", "alice", OK)
|
|
bob #:# "nothing else delivered before the server is down"
|
|
|
|
bob <# ("", "alice", DOWN)
|
|
alice #: ("2", "bob", "SEND 11\nhello again") #> ("2", "bob", MID 2)
|
|
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 2)
|
|
_ -> False
|
|
bob <# ("", "alice", UP)
|
|
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> False
|
|
bob #: ("12", "alice", "ACK 2") #> ("12", "alice", OK)
|
|
|
|
removeFile testStoreLogFile
|
|
removeFile testDB
|
|
where
|
|
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
|
withAgent = withSmpAgentThreadOn_ (ATransport t) (agentTestPort, testPort, testDB) (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 INV")
|
|
let cReq' = serializeConnReq cReq
|
|
bob #: ("11", "alice2", "JOIN " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK)
|
|
("", "bob2", Right (CONF _confId "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 :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 9\nhello too") #> ("14", "alice", MID 2)
|
|
bob <# ("", "alice", SENT 2)
|
|
-- if delivery is blocked it won't go further
|
|
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
|
|
alice #: ("3", "bob", "ACK 2") #> ("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 :" <> msg)
|
|
alice <#= \case ("", "bob", SENT m) -> m == mId; _ -> False
|
|
(_, "bob", Right (MID _)) <- alice #: ("5", "bob", "SEND :over quota")
|
|
|
|
alice #: ("1", "bob2", "SEND :hello") #> ("1", "bob2", MID 1)
|
|
-- if delivery is blocked it won't go further
|
|
alice <# ("", "bob2", SENT 1)
|
|
|
|
connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO ()
|
|
connect (h1, name1) (h2, name2) = do
|
|
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW INV")
|
|
let cReq' = serializeConnReq cReq
|
|
h2 #: ("c2", name1, "JOIN " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK)
|
|
("", _, Right (CONF connId "info2")) <- (h1 <#:)
|
|
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
|
|
h2 <# ("", name1, INFO "info1")
|
|
h2 <# ("", name1, CON)
|
|
h1 <# ("", name2, CON)
|
|
|
|
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 :" <> 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 INV")
|
|
-- let cReq' = serializeConnReq cReq
|
|
-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN " <> cReq' <> " 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)
|
|
|
|
samplePublicKey :: ByteString
|
|
samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj-toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP-Tm4sokaFDTIG3QJFzOjC-_9nW4MUjAOFll9PCp9kaEFHJ_YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju_f6kAayvYKW3_lbJNXCmyinAccBosO08_0sUxvtuniIo18kfYJE0UmP1ReCjhMP-O-yOmwZJini_QelJk_Pez8IIDDWnY1qYQsN_q7ocjakOYrpGG7mig6JMFpDJtD6istR"
|
|
|
|
syntaxTests :: forall c. Transport c => TProxy c -> Spec
|
|
syntaxTests t = do
|
|
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
|
|
describe "NEW" do
|
|
describe "valid" do
|
|
-- TODO: add tests with defined connection alias
|
|
it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
|
|
describe "invalid" do
|
|
-- TODO: add tests with defined connection alias
|
|
it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
|
|
|
|
describe "JOIN" do
|
|
describe "valid" do
|
|
-- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)
|
|
-- TODO: add tests with defined connection alias
|
|
it "using same server as in invitation" $
|
|
("311", "a", "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2Flocalhost%3A5000%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")
|
|
describe "invalid" do
|
|
-- TODO: JOIN is not merged yet - to be added
|
|
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
|
|
where
|
|
-- simple test for one command with the expected response
|
|
(>#>) :: ARawTransmission -> ARawTransmission -> Expectation
|
|
command >#> response = 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 = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, cAlias, cmd) -> (cId, cAlias, B.words cmd))
|