503 lines
24 KiB
Haskell
503 lines
24 KiB
Haskell
{-# 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.DoubleRatchetTests (doubleRatchetTests)
|
|
import AgentTests.FunctionalAPITests (functionalAPITests)
|
|
import AgentTests.NotificationTests (notificationTests)
|
|
import AgentTests.SQLiteTests (storeTests)
|
|
import AgentTests.SchemaDump (schemaDumpTest)
|
|
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 (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn)
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import qualified Simplex.Messaging.Agent.Protocol as A
|
|
import Simplex.Messaging.Encoding.String
|
|
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 "Double ratchet tests" doubleRatchetTests
|
|
describe "Functional API" $ functionalAPITests (ATransport t)
|
|
describe "Notification tests" $ notificationTests (ATransport t)
|
|
describe "SQLite store" storeTests
|
|
describe "SQLite schema dump" schemaDumpTest
|
|
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 and server reconnection" $ do
|
|
it "should deliver messages after losing server connection and re-connecting" $
|
|
smpAgentTest2_2_2_needs_server $ testMsgDeliveryServerRestart t
|
|
it "should connect to the server when server goes up if it initially was down" $
|
|
smpAgentTestN [] $ testServerConnectionAfterError t
|
|
it "should deliver pending messages after agent restarting" $
|
|
smpAgentTest1_1_1 $ testMsgDeliveryAgentRestart t
|
|
it "should concurrently deliver messages to connections without blocking" $
|
|
smpAgentTest2_2_1 $ testConcurrentMsgDelivery t
|
|
it "should deliver messages if one of connections has quota exceeded" $
|
|
smpAgentTest2_2_1 $ testMsgDeliveryQuotaExceeded t
|
|
|
|
tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent)
|
|
tGetAgent h = do
|
|
t@(_, _, cmd) <- tGet SAgent h
|
|
case cmd of
|
|
Right CONNECT {} -> tGetAgent h
|
|
Right DISCONNECT {} -> tGetAgent h
|
|
_ -> pure t
|
|
|
|
-- | receive message to handle `h`
|
|
(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent)
|
|
(<#:) = tGetAgent
|
|
|
|
-- | 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, connId, cmd) = 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 (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation
|
|
action =#> p = action >>= (`shouldSatisfy` p . correctTransmission)
|
|
|
|
correctTransmission :: ATransmissionOrError a -> ATransmission a
|
|
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
|
|
(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation
|
|
h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, 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` tGetAgent 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' = strEncode 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)
|
|
-- 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", MID 4)
|
|
alice <# ("", "bob", SENT 4)
|
|
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> False
|
|
bob #: ("12", "alice", "ACK 4") #> ("12", "alice", OK)
|
|
alice #: ("4", "bob", "SEND F :how are you?") #> ("4", "bob", MID 5)
|
|
alice <# ("", "bob", SENT 5)
|
|
bob <#= \case ("", "alice", Msg "how are you?") -> True; _ -> False
|
|
bob #: ("13", "alice", "ACK 5") #> ("13", "alice", OK)
|
|
bob #: ("14", "alice", "SEND F 9\nhello too") #> ("14", "alice", MID 6)
|
|
bob <# ("", "alice", SENT 6)
|
|
alice <#= \case ("", "bob", Msg "hello too") -> True; _ -> False
|
|
alice #: ("3a", "bob", "ACK 6") #> ("3a", "bob", OK)
|
|
bob #: ("15", "alice", "SEND F 9\nmessage 1") #> ("15", "alice", MID 7)
|
|
bob <# ("", "alice", SENT 7)
|
|
alice <#= \case ("", "bob", Msg "message 1") -> True; _ -> 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", MID 8)
|
|
bob <# ("", "alice", MERR 8 (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' = strEncode 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 F :hello") #> ("2", bobConn, MID 4)
|
|
alice <# ("", bobConn, SENT 4)
|
|
bob <#= \case ("", c, Msg "hello") -> c == aliceConn; _ -> False
|
|
bob #: ("12", aliceConn, "ACK 4") #> ("12", aliceConn, OK)
|
|
alice #: ("3", bobConn, "SEND F :how are you?") #> ("3", bobConn, MID 5)
|
|
alice <# ("", bobConn, SENT 5)
|
|
bob <#= \case ("", c, Msg "how are you?") -> c == aliceConn; _ -> False
|
|
bob #: ("13", aliceConn, "ACK 5") #> ("13", aliceConn, OK)
|
|
bob #: ("14", aliceConn, "SEND F 9\nhello too") #> ("14", aliceConn, MID 6)
|
|
bob <# ("", aliceConn, SENT 6)
|
|
alice <#= \case ("", c, Msg "hello too") -> c == bobConn; _ -> False
|
|
alice #: ("3a", bobConn, "ACK 6") #> ("3a", bobConn, OK)
|
|
bob #: ("15", aliceConn, "SEND F 9\nmessage 1") #> ("15", aliceConn, MID 7)
|
|
bob <# ("", aliceConn, SENT 7)
|
|
alice <#= \case ("", c, Msg "message 1") -> c == bobConn; _ -> 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, MID 8)
|
|
bob <# ("", aliceConn, MERR 8 (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' = strEncode 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 F :hi") #> ("3", "bob", MID 4)
|
|
alice <# ("", "bob", SENT 4)
|
|
bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False
|
|
bob #: ("13", "alice", "ACK 4") #> ("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 F :hi there") #> ("5", "tom", MID 4)
|
|
alice <# ("", "tom", SENT 4)
|
|
tom <#= \case ("", "alice", Msg "hi there") -> True; _ -> False
|
|
tom #: ("23", "alice", "ACK 4") #> ("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' = strEncode 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 F :hi") #> ("3", bobConn, MID 4)
|
|
alice <# ("", bobConn, SENT 4)
|
|
bob <#= \case ("", c, Msg "hi") -> c == aliceConn; _ -> 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 CON")
|
|
let cReq' = strEncode 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 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 INV") =#> \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 <# ("", "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 F 2\nhi") #> ("1", "alice", MID 4)
|
|
bob <# ("", "alice", SENT 4)
|
|
alice <#= \case ("", "bob", Msg "hi") -> True; _ -> 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", MID 5)
|
|
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 "hello again") -> True; _ -> False
|
|
alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK)
|
|
|
|
removeFile testStoreLogFile
|
|
where
|
|
withServer test' = withSmpServerStoreLogOn (ATransport t) testPort2 (const test') `shouldReturn` ()
|
|
|
|
testServerConnectionAfterError :: forall c. Transport c => TProxy c -> [c] -> IO ()
|
|
testServerConnectionAfterError t _ = do
|
|
withAgent1 $ \bob -> do
|
|
withAgent2 $ \alice -> do
|
|
withServer $ do
|
|
connect (bob, "bob") (alice, "alice")
|
|
|
|
bob <# ("", "", 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") #> ("1", "alice", ERR (BROKER NETWORK))
|
|
alice #: ("1", "bob", "SUB") #> ("1", "bob", ERR (BROKER NETWORK))
|
|
withServer $ do
|
|
alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
|
|
alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False
|
|
bob <# ("", "", UP server ["alice"])
|
|
bob <#= \case ("", "alice", Msg "hello") -> True; _ -> 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
|
|
withAgent2 = withAgent agentTestPort2 testDB2
|
|
withAgent :: String -> String -> (c -> IO a) -> IO a
|
|
withAgent agentPort agentDB = withSmpAgentThreadOn_ (ATransport t) (agentPort, testPort2, agentDB) (pure ()) . const . testSMPAgentClientOn agentPort
|
|
|
|
testMsgDeliveryAgentRestart :: Transport c => TProxy c -> c -> IO ()
|
|
testMsgDeliveryAgentRestart t bob = do
|
|
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 <# ("", "", UP server ["alice"])
|
|
bob <#= \case ("", "alice", Msg "hello again") -> True; _ -> 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) (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' = strEncode 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 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 #: ("1", "bob2", "SEND F :hello") #> ("1", "bob2", MID 4)
|
|
-- if delivery is blocked it won't go further
|
|
alice <# ("", "bob2", SENT 4)
|
|
|
|
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' = strEncode 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 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 INV")
|
|
-- let cReq' = strEncode 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)
|
|
|
|
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")
|
|
describe "NEW" $ do
|
|
describe "valid" $ do
|
|
-- TODO: add tests with defined connection id
|
|
it "with correct parameter" $ ("211", "", "NEW INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False
|
|
describe "invalid" $ do
|
|
-- TODO: add tests with defined connection id
|
|
it "with incorrect parameter" $ ("222", "", "NEW hi") >#> ("222", "", "ERR CMD SYNTAX")
|
|
|
|
describe "JOIN" $ do
|
|
describe "valid" $ do
|
|
it "using same server as in invitation" $
|
|
( "311",
|
|
"a",
|
|
"JOIN 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=1"
|
|
<> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D"
|
|
<> " 14\nbob's connInfo"
|
|
)
|
|
>#> ("311", "a", "ERR SMP AUTH")
|
|
describe "invalid" $ do
|
|
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, connId, cmd) -> (cId, connId, B.words cmd))
|