mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 20:35:08 +00:00
remove BlockArguments extension (#220)
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
52eef2d7c7
commit
f640e71f82
@@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
@@ -129,7 +128,7 @@ data ATransport = forall c. Transport c => ATransport (TProxy c)
|
||||
runTransportServer :: (Transport c, MonadUnliftIO m) => TMVar Bool -> ServiceName -> (c -> m ()) -> m ()
|
||||
runTransportServer started port server = do
|
||||
clients <- newTVarIO S.empty
|
||||
E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do
|
||||
E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) $ \sock -> forever $ do
|
||||
c <- liftIO $ acceptConnection sock
|
||||
tid <- forkFinally (server c) (const $ liftIO $ closeConnection c)
|
||||
atomically . modifyTVar clients $ S.insert tid
|
||||
|
||||
+10
-11
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -33,7 +32,7 @@ agentTests (ATransport t) = do
|
||||
describe "Functional API" $ functionalAPITests (ATransport t)
|
||||
describe "SQLite store" storeTests
|
||||
describe "SMP agent protocol syntax" $ syntaxTests t
|
||||
describe "Establishing duplex connection" do
|
||||
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)" $
|
||||
@@ -46,19 +45,19 @@ agentTests (ATransport t) = do
|
||||
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
|
||||
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
|
||||
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
|
||||
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" $
|
||||
@@ -354,21 +353,21 @@ samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSG
|
||||
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
|
||||
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
|
||||
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
|
||||
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%3A5001%2F1234-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo") >#> ("311", "a", "ERR SMP AUTH")
|
||||
describe "invalid" do
|
||||
describe "invalid" $ do
|
||||
-- TODO: JOIN is not merged yet - to be added
|
||||
it "no parameters" $ ("321", "", "JOIN") >#> ("321", "", "ERR CMD SYNTAX")
|
||||
where
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -71,42 +70,42 @@ action `throwsError` e = runExceptT action `shouldReturn` Left e
|
||||
-- TODO add null port tests
|
||||
storeTests :: Spec
|
||||
storeTests = do
|
||||
withStore2 do
|
||||
withStore2 $ do
|
||||
describe "stress test" testConcurrentWrites
|
||||
withStore do
|
||||
describe "store setup" do
|
||||
withStore $ do
|
||||
describe "store setup" $ do
|
||||
testCompiledThreadsafe
|
||||
testForeignKeysEnabled
|
||||
describe "store methods" do
|
||||
describe "Queue and Connection management" do
|
||||
describe "createRcvConn" do
|
||||
describe "store methods" $ do
|
||||
describe "Queue and Connection management" $ do
|
||||
describe "createRcvConn" $ do
|
||||
testCreateRcvConn
|
||||
testCreateRcvConnRandomId
|
||||
testCreateRcvConnDuplicate
|
||||
describe "createSndConn" do
|
||||
describe "createSndConn" $ do
|
||||
testCreateSndConn
|
||||
testCreateSndConnRandomID
|
||||
testCreateSndConnDuplicate
|
||||
describe "getAllConnIds" testGetAllConnIds
|
||||
describe "getRcvConn" testGetRcvConn
|
||||
describe "deleteConn" do
|
||||
describe "deleteConn" $ do
|
||||
testDeleteRcvConn
|
||||
testDeleteSndConn
|
||||
testDeleteDuplexConn
|
||||
describe "upgradeRcvConnToDuplex" do
|
||||
describe "upgradeRcvConnToDuplex" $ do
|
||||
testUpgradeRcvConnToDuplex
|
||||
describe "upgradeSndConnToDuplex" do
|
||||
describe "upgradeSndConnToDuplex" $ do
|
||||
testUpgradeSndConnToDuplex
|
||||
describe "set Queue status" do
|
||||
describe "setRcvQueueStatus" do
|
||||
describe "set Queue status" $ do
|
||||
describe "setRcvQueueStatus" $ do
|
||||
testSetRcvQueueStatus
|
||||
testSetRcvQueueStatusNoQueue
|
||||
describe "setSndQueueStatus" do
|
||||
describe "setSndQueueStatus" $ do
|
||||
testSetSndQueueStatus
|
||||
testSetSndQueueStatusNoQueue
|
||||
testSetQueueStatusDuplex
|
||||
describe "Msg management" do
|
||||
describe "create Msg" do
|
||||
describe "Msg management" $ do
|
||||
describe "create Msg" $ do
|
||||
testCreateRcvMsg
|
||||
testCreateSndMsg
|
||||
testCreateRcvAndSndMsgs
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -31,10 +30,10 @@ rsaKeySize = 2048 `div` 8
|
||||
serverTests :: ATransport -> Spec
|
||||
serverTests t = do
|
||||
describe "SMP syntax" $ syntaxTests t
|
||||
describe "SMP queues" do
|
||||
describe "SMP queues" $ do
|
||||
describe "NEW and KEY commands, SEND messages" $ testCreateSecure t
|
||||
describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t
|
||||
describe "SMP messages" do
|
||||
describe "SMP messages" $ do
|
||||
describe "duplex communication over 2 SMP connections" $ testDuplex t
|
||||
describe "switch subscription to another SMP queue" $ testSwitchSub t
|
||||
describe "Store log" $ testWithStoreLog t
|
||||
@@ -445,12 +444,12 @@ sampleSig = "gM8qn2Vx3GkhIp2hgrji9uhfXKpgtKDmc0maxdP8GvbORUxMCTlLG8Q/gNcl3pQVOzm
|
||||
syntaxTests :: ATransport -> Spec
|
||||
syntaxTests (ATransport t) = do
|
||||
it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX")
|
||||
describe "NEW" do
|
||||
describe "NEW" $ do
|
||||
it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX")
|
||||
it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX")
|
||||
it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH")
|
||||
it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH")
|
||||
describe "KEY" do
|
||||
describe "KEY" $ do
|
||||
it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH")
|
||||
it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")
|
||||
it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX")
|
||||
@@ -460,7 +459,7 @@ syntaxTests (ATransport t) = do
|
||||
noParamsSyntaxTest "ACK"
|
||||
noParamsSyntaxTest "OFF"
|
||||
noParamsSyntaxTest "DEL"
|
||||
describe "SEND" do
|
||||
describe "SEND" $ do
|
||||
it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH")
|
||||
it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH")
|
||||
it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX")
|
||||
@@ -468,13 +467,13 @@ syntaxTests (ATransport t) = do
|
||||
it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")
|
||||
it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX")
|
||||
it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX")
|
||||
describe "PING" do
|
||||
describe "PING" $ do
|
||||
it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG")
|
||||
describe "broker response not allowed" do
|
||||
describe "broker response not allowed" $ do
|
||||
it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED")
|
||||
where
|
||||
noParamsSyntaxTest :: ByteString -> Spec
|
||||
noParamsSyntaxTest cmd = describe (B.unpack cmd) do
|
||||
noParamsSyntaxTest cmd = describe (B.unpack cmd) $ do
|
||||
it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH")
|
||||
it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX")
|
||||
it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH")
|
||||
|
||||
Reference in New Issue
Block a user