Skip to content

Commit 34df7e4

Browse files
epoberezkinepoberezkin
committed
test: upgrade/downgrade to/from service subscriptions
1 parent 6092fc4 commit 34df7e4

File tree

2 files changed

+153
-26
lines changed

2 files changed

+153
-26
lines changed

‎tests/SMPClient.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -183,6 +183,12 @@ testSMPClient_ host port vr serviceCreds_ client = do
183183
| authCmdsSMPVersion `isCompatible` vr = Just alpnSupportedSMPHandshakes
184184
| otherwise = Nothing
185185

186+
runSMPClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
187+
runSMPClient _ test' = testSMPClient test'
188+
189+
runSMPServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
190+
runSMPServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test'
191+
186192
testNtfServiceClient :: Transport c => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a
187193
testNtfServiceClient _ keys client = do
188194
tlsNtfServerCreds <- loadServerCredential ntfTestServerCredentials

‎tests/ServerTests.hs‎

Lines changed: 147 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -28,14 +28,15 @@ import Data.Bifunctor (first)
2828
import qualified Data.ByteString.Base64 as B64
2929
import Data.ByteString.Char8 (ByteString)
3030
import qualified Data.ByteString.Char8 as B
31+
import Data.Foldable (foldrM)
3132
import Data.Hashable (hash)
3233
import qualified Data.IntSet as IS
3334
import Data.List.NonEmpty (NonEmpty)
35+
import Data.Maybe (catMaybes)
3436
import Data.String (IsString (..))
3537
import Data.Type.Equality
3638
import qualified Data.X509.Validation as XV
3739
import GHC.Stack (withFrozenCallStack)
38-
import qualified Network.TLS as TLS
3940
import SMPClient
4041
import qualified Simplex.Messaging.Crypto as C
4142
import Simplex.Messaging.Encoding
@@ -82,6 +83,7 @@ serverTests = do
8283
describe "Concurrent sending and delivery" testConcurrentSendDelivery
8384
describe "Service message subscriptions" $ do
8485
testServiceDeliverSubscribe
86+
testServiceUpgradeAndDowngrade
8587
describe "Store log" testWithStoreLog
8688
describe "Restore messages" testRestoreMessages
8789
describe "Restore messages (old / v2)" testRestoreExpireMessages
@@ -135,10 +137,15 @@ serviceSignSendRecv h pk serviceKey t = do
135137
[r] <- signSendRecv_ h pk (Just serviceKey) t
136138
pure r
137139

140+
serviceSignSendRecv2 :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (Transmission (Either ErrorType BrokerMsg), Transmission (Either ErrorType BrokerMsg))
141+
serviceSignSendRecv2 h pk serviceKey t = do
142+
[r1, r2] <- signSendRecv_ h pk (Just serviceKey) t
143+
pure (r1, r2)
144+
138145
signSendRecv_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO (NonEmpty (Transmission (Either ErrorType BrokerMsg)))
139146
signSendRecv_ h pk serviceKey_ t = do
140147
signSend_ h pk serviceKey_ t
141-
liftIO $ tGetClient h
148+
tGetClient h
142149

143150
signSend_ :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> Maybe C.PrivateKeyEd25519 -> (ByteString, EntityId, Command p) -> IO ()
144151
signSend_ h@THandle {params} (C.APrivateAuthKey a pk) serviceKey_ (corrId, qId, cmd) = do
@@ -667,18 +674,18 @@ testConcurrentSendDelivery =
667674

668675
testServiceDeliverSubscribe :: SpecWith (ASrvTransport, AStoreType)
669676
testServiceDeliverSubscribe =
670-
it "" $ \(at@(ATransport t), msType) -> do
677+
it "should create queue as service and subscribe with SUBS after reconnect" $ \(at@(ATransport t), msType) -> do
671678
g <- C.newRandom
672679
creds <- genCredentials g Nothing (0, 2400) "localhost"
673680
let (_fp, tlsCred) = tlsCredentials [creds]
674681
serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g
675682
let aServicePK = C.APrivateAuthKey C.SEd25519 servicePK
676-
withSmpServerConfigOn at (cfgMS msType) testPort $ \_ -> runClient t $ \h -> do
683+
withSmpServerConfigOn at (cfgMS msType) testPort $ \_ -> runSMPClient t $ \h -> do
677684
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
678685
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
679686
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
680687

681-
(rId, sId, dec, serviceId) <- runServiceClient t (tlsCred, serviceKeys) $ \sh -> do
688+
(rId, sId, dec, serviceId) <- runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
682689
Resp "1" NoEntity (ERR SERVICE) <- signSendRecv sh rKey ("1", NoEntity, New rPub dhPub)
683690
Resp "2" NoEntity (Ids_ rId sId srvDh serviceId) <- serviceSignSendRecv sh rKey servicePK ("2", NoEntity, New rPub dhPub)
684691
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
@@ -697,35 +704,149 @@ testServiceDeliverSubscribe =
697704
Resp "9" _ OK <- signSendRecv h sKey ("9", sId, _SEND "hello 3")
698705
pure (rId, sId, dec, serviceId)
699706

700-
runServiceClient t (tlsCred, serviceKeys) $ \sh -> do
707+
runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
701708
Resp "10" NoEntity (ERR (CMD NO_AUTH)) <- signSendRecv sh aServicePK ("10", NoEntity, SUBS)
702-
mId3 <- signSendRecv sh aServicePK ("11", serviceId, SUBS) >>= \case -- possible race between SOKS response and MSG
703-
Resp "11" serviceId' (SOKS n) -> do
704-
n `shouldBe` 1
705-
serviceId' `shouldBe` serviceId
706-
Resp "" rId'' (Msg mId3 msg3) <- tGet1 sh
707-
rId'' `shouldBe` rId
708-
dec mId3 msg3 `shouldBe` Right "hello 3"
709-
pure mId3
710-
Resp "" rId'' (Msg mId3 msg3) -> do
711-
rId'' `shouldBe` rId
712-
dec mId3 msg3 `shouldBe` Right "hello 3"
713-
Resp "11" serviceId' (SOKS n) <- tGet1 sh
714-
n `shouldBe` 1
715-
serviceId' `shouldBe` serviceId
716-
pure mId3
717-
r -> error $ "unexpected response " <> take 100 (show r)
709+
signSend_ sh aServicePK Nothing ("11", serviceId, SUBS)
710+
[mId3] <-
711+
fmap catMaybes $
712+
receiveInAnyOrder -- race between SOKS and MSG, clients can handle it
713+
sh
714+
[ \case
715+
Resp "11" serviceId' (SOKS n) -> do
716+
n `shouldBe` 1
717+
serviceId' `shouldBe` serviceId
718+
pure $ Just Nothing
719+
_ -> pure Nothing,
720+
\case
721+
Resp "" rId'' (Msg mId3 msg3) -> do
722+
rId'' `shouldBe` rId
723+
dec mId3 msg3 `shouldBe` Right "hello 3"
724+
pure $ Just $ Just mId3
725+
_ -> pure Nothing
726+
]
718727
Resp "12" _ OK <- signSendRecv sh rKey ("12", rId, ACK mId3)
719728
Resp "14" _ OK <- signSendRecv h sKey ("14", sId, _SEND "hello 4")
720729
Resp "" _ (Msg mId4 msg4) <- tGet1 sh
721730
dec mId4 msg4 `shouldBe` Right "hello 4"
722731
Resp "15" _ OK <- signSendRecv sh rKey ("15", rId, ACK mId4)
723732
pure ()
733+
734+
testServiceUpgradeAndDowngrade :: SpecWith (ASrvTransport, AStoreType)
735+
testServiceUpgradeAndDowngrade =
736+
it "should create queue as client and switch to service and back" $ \(at@(ATransport t), msType) -> do
737+
g <- C.newRandom
738+
creds <- genCredentials g Nothing (0, 2400) "localhost"
739+
let (_fp, tlsCred) = tlsCredentials [creds]
740+
serviceKeys@(_, servicePK) <- atomically $ C.generateKeyPair g
741+
let aServicePK = C.APrivateAuthKey C.SEd25519 servicePK
742+
withSmpServerConfigOn at (cfgMS msType) testPort $ \_ -> runSMPClient t $ \h -> do
743+
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
744+
(dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
745+
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
746+
(rPub2, rKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
747+
(dhPub2, dhPriv2 :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
748+
(sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
749+
750+
(rId, sId, dec) <- runSMPClient t $ \sh -> do
751+
Resp "1" NoEntity (Ids rId sId srvDh) <- signSendRecv sh rKey ("1", NoEntity, New rPub dhPub)
752+
let dec = decryptMsgV3 $ C.dh' srvDh dhPriv
753+
Resp "2" sId' OK <- signSendRecv h sKey ("2", sId, SKEY sPub)
754+
sId' `shouldBe` sId
755+
Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello")
756+
Resp "" rId' (Msg mId1 msg1) <- tGet1 sh
757+
rId' `shouldBe` rId
758+
dec mId1 msg1 `shouldBe` Right "hello"
759+
Resp "4" _ OK <- signSendRecv sh rKey ("4", rId, ACK mId1)
760+
Resp "5" _ OK <- signSendRecv h sKey ("5", sId, _SEND "hello 2")
761+
pure (rId, sId, dec)
762+
763+
-- split to prevent message delivery
764+
(rId2, sId2, dec2) <- runSMPClient t $ \sh -> do
765+
Resp "6" NoEntity (Ids rId2 sId2 srvDh2) <- signSendRecv sh rKey2 ("6", NoEntity, New rPub2 dhPub2)
766+
let dec2 = decryptMsgV3 $ C.dh' srvDh2 dhPriv2
767+
Resp "7" sId2' OK <- signSendRecv h sKey2 ("7", sId2, SKEY sPub2)
768+
sId2' `shouldBe` sId2
769+
pure (rId2, sId2, dec2)
770+
771+
serviceId <- runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
772+
Resp "8" _ (ERR SERVICE) <- signSendRecv sh rKey ("8", rId, SUB)
773+
(Resp "9" rId' (SOK (Just serviceId)), Resp "" rId'' (Msg mId2 msg2)) <- serviceSignSendRecv2 sh rKey servicePK ("9", rId, SUB)
774+
rId' `shouldBe` rId
775+
rId'' `shouldBe` rId
776+
dec mId2 msg2 `shouldBe` Right "hello 2"
777+
(Resp "10" rId2' (SOK (Just serviceId'))) <- serviceSignSendRecv sh rKey2 servicePK ("10", rId2, SUB)
778+
rId2' `shouldBe` rId2
779+
serviceId' `shouldBe` serviceId
780+
Resp "10.1" _ OK <- signSendRecv sh rKey ("10.1", rId, ACK mId2)
781+
pure serviceId
782+
783+
Resp "11" _ OK <- signSendRecv h sKey ("11", sId, _SEND "hello 3.1")
784+
Resp "12" _ OK <- signSendRecv h sKey2 ("12", sId2, _SEND "hello 3.2")
785+
786+
runSMPServiceClient t (tlsCred, serviceKeys) $ \sh -> do
787+
signSend_ sh aServicePK Nothing ("14", serviceId, SUBS)
788+
[(rKey3_1, rId3_1, mId3_1), (rKey3_2, rId3_2, mId3_2)] <-
789+
fmap catMaybes $
790+
receiveInAnyOrder -- race between SOKS and MSG, clients can handle it
791+
sh
792+
[ \case
793+
Resp "14" serviceId' (SOKS n) -> do
794+
n `shouldBe` 2
795+
serviceId' `shouldBe` serviceId
796+
pure $ Just Nothing
797+
_ -> pure Nothing,
798+
\case
799+
Resp "" rId'' (Msg mId3 msg3) | rId'' == rId -> do
800+
dec mId3 msg3 `shouldBe` Right "hello 3.1"
801+
pure $ Just $ Just (rKey, rId, mId3)
802+
_ -> pure Nothing,
803+
\case
804+
Resp "" rId'' (Msg mId3 msg3) | rId'' == rId2 -> do
805+
dec2 mId3 msg3 `shouldBe` Right "hello 3.2"
806+
pure $ Just $ Just (rKey2, rId2, mId3)
807+
_ -> pure Nothing
808+
]
809+
Resp "15" _ OK <- signSendRecv sh rKey3_1 ("15", rId3_1, ACK mId3_1)
810+
Resp "16" _ OK <- signSendRecv sh rKey3_2 ("16", rId3_2, ACK mId3_2)
811+
pure ()
812+
813+
Resp "17" _ OK <- signSendRecv h sKey ("17", sId, _SEND "hello 4")
814+
815+
runSMPClient t $ \sh -> do
816+
Resp "18" _ (ERR SERVICE) <- signSendRecv sh aServicePK ("18", serviceId, SUBS)
817+
(Resp "19" rId' (SOK Nothing), Resp "" rId'' (Msg mId4 msg4)) <- signSendRecv2 sh rKey ("19", rId, SUB)
818+
rId' `shouldBe` rId
819+
rId'' `shouldBe` rId
820+
dec mId4 msg4 `shouldBe` Right "hello 4"
821+
Resp "20" _ OK <- signSendRecv sh rKey ("20", rId, ACK mId4)
822+
Resp "21" _ OK <- signSendRecv h sKey ("21", sId, _SEND "hello 5")
823+
Resp "" _ (Msg mId5 msg5) <- tGet1 sh
824+
dec mId5 msg5 `shouldBe` Right "hello 5"
825+
Resp "22" _ OK <- signSendRecv sh rKey ("22", rId, ACK mId5)
826+
827+
Resp "23" rId2' (SOK Nothing) <- signSendRecv sh rKey2 ("23", rId2, SUB)
828+
rId2' `shouldBe` rId2
829+
Resp "24" _ OK <- signSendRecv h sKey ("24", sId, _SEND "hello 6")
830+
Resp "" _ (Msg mId6 msg6) <- tGet1 sh
831+
dec mId6 msg6 `shouldBe` Right "hello 6"
832+
Resp "25" _ OK <- signSendRecv sh rKey ("25", rId, ACK mId6)
833+
pure ()
834+
835+
receiveInAnyOrder :: (HasCallStack, Transport c) => THandleSMP c 'TClient -> [(CorrId, EntityId, Either ErrorType BrokerMsg) -> IO (Maybe b)] -> IO [b]
836+
receiveInAnyOrder h = fmap reverse . go []
724837
where
725-
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
726-
runClient _ test' = testSMPClient test'
727-
runServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
728-
runServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test'
838+
go rs [] = pure rs
839+
go rs ps = withFrozenCallStack $ do
840+
r <- 5000000 `timeout` get >>= maybe (error "inAnyOrder timeout") pure
841+
(r_, ps') <- foldrM (choose r) (Nothing, []) ps
842+
case r_ of
843+
Just r' -> go (r' : rs) ps'
844+
Nothing -> error $ "unexpected event: " <> show r
845+
get = do
846+
[r] <- tGetClient h
847+
pure r
848+
choose r p (Nothing, ps') = (maybe (Nothing, p : ps') ((,ps') . Just)) <$> p r
849+
choose _ p (Just r, ps') = pure (Just r, p : ps')
729850

730851
testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
731852
testWithStoreLog =

0 commit comments

Comments
 (0)