dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-23 01:45:16 +00:00
Code Issues Packages Projects Releases Wiki Activity

parameterize protocol by error type (#644)

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-02-17 20:46:01 +00:00
committed by GitHub
parent 2ae3100bed
commit 2ddfb044fc
12 changed files with 216 additions and 176 deletions
Download Patch File Download Diff File Expand all files Collapse all files
tests/CoreTests/ProtocolErrorTests.hs
+7 -5
View File
@@ -6,7 +6,7 @@ module CoreTests.ProtocolErrorTests where
import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Test.Hspec
@@ -17,12 +17,14 @@ protocolErrorTests :: Spec
protocolErrorTests = modifyMaxSuccess (const 1000) $ do
describe "errors parsing / serializing" $ do
it "should parse SMP protocol errors" . property $ \(err :: AgentErrorType) ->
errServerHasSpaces err
errHasSpaces err
|| parseAll strP (strEncode err) == Right err
it "should parse SMP agent errors" . property $ \(err :: AgentErrorType) ->
errServerHasSpaces err
errHasSpaces err
|| parseAll strP (strEncode err) == Right err
where
errServerHasSpaces = \case
BROKER srv _ -> ' ' `B.elem` encodeUtf8 (T.pack srv)
errHasSpaces = \case
BROKER srv (RESPONSE e) -> hasSpaces srv || hasSpaces e
BROKER srv _ -> hasSpaces srv
_ -> False
hasSpaces s = ' ' `B.elem` encodeUtf8 (T.pack s)
tests/NtfServerTests.hs
+3 -3
View File
@@ -64,16 +64,16 @@ ntfSyntaxTests (ATransport t) = do
Expectation
command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response
pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission NtfResponse
pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse
pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command))
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right () <- tPut1 h (sgn, t)
tGet1 h
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission NtfResponse)
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right () <- tPut1 h (Just $ C.sign pk t, t)
tests/ServerTests.hs
+10 -10
View File
@@ -63,7 +63,7 @@ serverTests t@(ATransport t') = do
testMsgExpireOnInterval t'
testMsgNOTExpireOnInterval t'
pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg
pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission ErrorType BrokerMsg
pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command))
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg
@@ -72,13 +72,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right () <- tPut1 h (sgn, t)
tGet1 h
signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg)
signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do
let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd)
Right () <- tPut1 h (Just $ C.sign pk t, t)
@@ -89,7 +89,7 @@ tPut1 h t = do
[r] <- tPut h [t]
pure r
tGet1 :: (ProtocolEncoding cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission cmd)
tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd)
tGet1 h = do
[r] <- liftIO $ tGet h
pure r
@@ -428,7 +428,7 @@ testSwitchSub (ATransport t) =
Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK mId3)
(ok3, OK) #== "accepts ACK from the 2nd TCP connection"
1000 `timeout` tGet @BrokerMsg rh1 >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg rh1 >>= \case
Nothing -> return ()
Just _ -> error "nothing else is delivered to the 1st TCP connection"
@@ -869,14 +869,14 @@ testMessageNotifications (ATransport t) =
Resp "5a" _ OK <- signSendRecv rh rKey ("5a", rId, ACK mId2)
(dec mId2 msg2, Right "hello again") #== "delivered from queue again"
Resp "" _ (NMSG _ _) <- tGet1 nh2
1000 `timeout` tGet @BrokerMsg nh1 >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg nh1 >>= \case
Nothing -> pure ()
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, NDEL)
Resp "7" _ OK <- signSendRecv sh sKey ("7", sId, _SEND' "hello there")
Resp "" _ (Msg mId3 msg3) <- tGet1 rh
(dec mId3 msg3, Right "hello there") #== "delivered from queue again"
1000 `timeout` tGet @BrokerMsg nh2 >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg nh2 >>= \case
Nothing -> pure ()
Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
@@ -895,7 +895,7 @@ testMsgExpireOnSend t =
testSMPClient @c $ \rh -> do
Resp "3" _ (Msg mId msg) <- signSendRecv rh rKey ("3", rId, SUB)
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
1000 `timeout` tGet @BrokerMsg rh >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
Just _ -> error "nothing else should be delivered"
@@ -911,7 +911,7 @@ testMsgExpireOnInterval t =
threadDelay 2500000
testSMPClient @c $ \rh -> do
Resp "2" _ OK <- signSendRecv rh rKey ("2", rId, SUB)
1000 `timeout` tGet @BrokerMsg rh >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
Just _ -> error "nothing should be delivered"
@@ -929,7 +929,7 @@ testMsgNOTExpireOnInterval t =
testSMPClient @c $ \rh -> do
Resp "2" _ (Msg mId msg) <- signSendRecv rh rKey ("2", rId, SUB)
(dec mId msg, Right "hello (should NOT expire)") #== "delivered"
1000 `timeout` tGet @BrokerMsg rh >>= \case
1000 `timeout` tGet @ErrorType @BrokerMsg rh >>= \case
Nothing -> return ()
Just _ -> error "nothing else should be delivered"