From 42dbb887f79776fd51b351f594e17d346389e3c2 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Fri, 25 Apr 2025 19:41:18 +0100 Subject: [PATCH] ntf server: allow retries when creating subscriptions, prohibit subscriptions with the same queue but another notifier key or token (#1525) * ntf server: allow retries when creating subscriptions, prohibit subscriptions with the same queue but another notifier key or token * sync files in the test * refactor --- src/Simplex/Messaging/Notifications/Server.hs | 104 ++++++++---------- .../Notifications/Server/Store/Postgres.hs | 63 +++++------ tests/AgentTests/NotificationTests.hs | 5 +- tests/NtfServerTests.hs | 52 ++++++++- tests/SMPClient.hs | 3 + 5 files changed, 132 insertions(+), 95 deletions(-) diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index c1f1aa9ab..dae98d301 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -537,7 +537,8 @@ runNtfClientTransport th@THandle {params} = do s <- asks subscriber ps <- asks pushServer expCfg <- asks $ inactiveClientExpiration . config - raceAny_ ([liftIO $ send th c, client c s ps, receive th c] <> disconnectThread_ c expCfg) + st <- asks store + raceAny_ ([liftIO $ send th c, client c s ps, liftIO $ receive st th c] <> disconnectThread_ c expCfg) `finally` liftIO (clientDisconnected c) where disconnectThread_ c (Just expCfg) = [liftIO $ disconnectTransport th (rcvActiveAt c) (sndActiveAt c) expCfg (pure True)] @@ -546,10 +547,10 @@ runNtfClientTransport th@THandle {params} = do clientDisconnected :: NtfServerClient -> IO () clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False -receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M () -receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do - ts <- L.toList <$> liftIO (tGet th) - atomically . (writeTVar rcvActiveAt $!) =<< liftIO getSystemTime +receive :: Transport c => NtfPostgresStore -> THandleNTF c 'TServer -> NtfServerClient -> IO () +receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do + ts <- L.toList <$> tGet th + atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime (errs, cmds) <- partitionEithers <$> mapM cmdAction ts write sndQ errs write rcvQ cmds @@ -560,70 +561,60 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ logError $ "invalid client request: " <> tshow e pure $ Left (corrId, entId, NRErr e) Right cmd -> - verified =<< verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd + verified =<< verifyNtfTransmission st ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd where verified = \case VRVerified req -> pure $ Right req - VRFailed -> do + VRFailed e -> do logError "unauthorized client request" - pure $ Left (corrId, entId, NRErr AUTH) + pure $ Left (corrId, entId, NRErr e) write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO () send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do ts <- atomically $ readTBQueue sndQ - void . liftIO $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts - atomically . (writeTVar sndActiveAt $!) =<< liftIO getSystemTime + void $ tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts + atomically . (writeTVar sndActiveAt $!) =<< getSystemTime -data VerificationResult = VRVerified NtfRequest | VRFailed +data VerificationResult = VRVerified NtfRequest | VRFailed ErrorType -verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult -verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do - st <- asks store - case cmd of - -- TODO [ntfdb] this looks suspicious, as if it can prevent repeated registrations - NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do - r_ <- liftIO $ getNtfTokenRegistration st tkn - pure $ - if verifyCmdAuthorization auth_ tAuth authorized k - then case r_ of - Right t@NtfTknRec {tknVerifyKey} - -- keys will be the same because of condition in `getNtfTokenRegistration` - | k == tknVerifyKey -> VRVerified $ tknCmd t c - | otherwise -> VRFailed - Left _ -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) - else VRFailed - NtfCmd SToken c -> do - t_ <- liftIO $ getNtfToken st entId - verifyToken_' t_ (`tknCmd` c) - NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> - liftIO $ verify <$> findNtfSubscription st tknId smpQueue - where - verify = \case - Right (t, s_) -> verifyToken t $ case s_ of - Nothing -> NtfReqNew corrId (ANE SSubscription sub) - Just s -> subCmd s c - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId - NtfCmd SSubscription c -> liftIO $ verify <$> getNtfSubscription st entId - where - verify = \case - Right (t, s) -> verifyToken t $ subCmd s c - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed +verifyNtfTransmission :: NtfPostgresStore -> Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> IO VerificationResult +verifyNtfTransmission st auth_ (tAuth, authorized, (corrId, entId, _)) = \case + NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) + | verifyCmdAuthorization auth_ tAuth authorized k -> + result <$> findNtfTokenRegistration st tkn + | otherwise -> pure $ VRFailed AUTH + where + result = \case + Right (Just t@NtfTknRec {tknVerifyKey}) + -- keys will be the same because of condition in `findNtfTokenRegistration` + | k == tknVerifyKey -> VRVerified $ tknCmd t c + | otherwise -> VRFailed AUTH + Right Nothing -> VRVerified (NtfReqNew corrId (ANE SToken tkn)) + Left e -> VRFailed e + NtfCmd SToken c -> either err verify <$> getNtfToken st entId + where + verify t = verifyToken t $ tknCmd t c + NtfCmd SSubscription c@(SNEW sub@(NewNtfSub tknId smpQueue _)) -> + either err verify <$> findNtfSubscription st tknId smpQueue + where + verify (t, s_) = verifyToken t $ case s_ of + Nothing -> NtfReqNew corrId (ANE SSubscription sub) + Just s -> subCmd s c + NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId + NtfCmd SSubscription c -> either err verify <$> getNtfSubscription st entId + where + verify (t, s) = verifyToken t $ subCmd s c where tknCmd t c = NtfReqCmd SToken (NtfTkn t) (corrId, entId, c) subCmd s c = NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c) - verifyToken_' :: Either ErrorType NtfTknRec -> (NtfTknRec -> NtfRequest) -> M VerificationResult - verifyToken_' t_ result = pure $ case t_ of - Right t -> verifyToken t $ result t - -- TODO [ntfdb] it should simply return error if it is not AUTH - Left _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed verifyToken :: NtfTknRec -> NtfRequest -> VerificationResult verifyToken NtfTknRec {tknVerifyKey} r | verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey = VRVerified r - | otherwise = VRFailed + | otherwise = VRFailed AUTH + err = \case -- signature verification for AUTH errors mitigates timing attacks for existence checks + AUTH -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed AUTH + e -> VRFailed e client :: NtfServerClient -> NtfSubscriber -> NtfPushServer -> M () client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPushServer {pushQ, intervalNotifiers} = @@ -669,9 +660,6 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu pure NROk | otherwise -> do logDebug "TVFY - incorrect code or token status" - liftIO $ print tkn - let NtfRegCode c = code - liftIO $ print $ B64.encode c pure $ NRErr AUTH TCHK -> do logDebug "TCHK" @@ -732,17 +720,15 @@ client NtfServerClient {rcvQ, sndQ} NtfSubscriber {newSubQ, smpAgent = ca} NtfPu atomically $ writeTBQueue newSubQ (srv, [sub]) incNtfStat subCreated pure $ NRSubId subId - -- TODO [ntfdb] we must allow repeated inserts that don't change credentials False -> pure $ NRErr AUTH pure (corrId, NoEntity, resp) - NtfReqCmd SSubscription (NtfSub NtfSubRec {smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do + NtfReqCmd SSubscription (NtfSub NtfSubRec {ntfSubId, smpQueue = SMPQueueNtf {smpServer, notifierId}, notifierKey = registeredNKey, subStatus}) (corrId, subId, cmd) -> do (corrId,subId,) <$> case cmd of SNEW (NewNtfSub _ _ notifierKey) -> do logDebug "SNEW - existing subscription" - -- possible improvement: retry if subscription failed, if pending or AUTH do nothing pure $ if notifierKey == registeredNKey - then NRSubId subId + then NRSubId ntfSubId else NRErr AUTH SCHK -> do logDebug "SCHK" diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index afe60e5b5..224aeaec7 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -145,18 +145,20 @@ ntfTknToRow NtfTknRec {ntfTknId, token, tknStatus, tknVerifyKey, tknDhPrivKey, t in (ntfTknId, pp, Binary ppToken, tknStatus, tknVerifyKey, tknDhPrivKey, tknDhSecret, Binary regCode, tknCronInterval, tknUpdatedAt) getNtfToken :: NtfPostgresStore -> NtfTokenId -> IO (Either ErrorType NtfTknRec) -getNtfToken st tknId = getNtfToken_ st " WHERE token_id = ?" (Only tknId) +getNtfToken st tknId = + (maybe (Left AUTH) Right =<<) <$> + getNtfToken_ st " WHERE token_id = ?" (Only tknId) -getNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType NtfTknRec) -getNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = +findNtfTokenRegistration :: NtfPostgresStore -> NewNtfEntity 'Token -> IO (Either ErrorType (Maybe NtfTknRec)) +findNtfTokenRegistration st (NewNtfTkn (DeviceToken pp ppToken) tknVerifyKey _) = getNtfToken_ st " WHERE push_provider = ? AND push_provider_token = ? AND verify_key = ?" (pp, Binary ppToken, tknVerifyKey) -getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType NtfTknRec) +getNtfToken_ :: ToRow q => NtfPostgresStore -> Query -> q -> IO (Either ErrorType (Maybe NtfTknRec)) getNtfToken_ st cond params = - withDB "getNtfToken" st $ \db -> runExceptT $ do - tkn <- ExceptT $ firstRow rowToNtfTkn AUTH $ DB.query db (ntfTknQuery <> cond) params - liftIO $ updateTokenDate st db tkn - pure tkn + withDB' "getNtfToken" st $ \db -> do + tkn_ <- maybeFirstRow rowToNtfTkn $ DB.query db (ntfTknQuery <> cond) params + mapM_ (updateTokenDate st db) tkn_ + pure tkn_ updateTokenDate :: NtfPostgresStore -> DB.Connection -> NtfTknRec -> IO () updateTokenDate st db NtfTknRec {ntfTknId, tknUpdatedAt} = do @@ -269,26 +271,28 @@ foldNtfSubscriptions st srv fetchCount state action = toNtfSub (ntfSubId, tokenId, nId, subStatus, notifierKey) = NtfSubRec {ntfSubId, tokenId, smpQueue = SMPQueueNtf srv nId, subStatus, notifierKey} +-- Returns token and subscription. +-- If subscription exists but belongs to another token, returns Left AUTH findNtfSubscription :: NtfPostgresStore -> NtfTokenId -> SMPQueueNtf -> IO (Either ErrorType (NtfTknRec, Maybe NtfSubRec)) -findNtfSubscription st tknId q@(SMPQueueNtf srv nId) = +findNtfSubscription st tknId q = withDB "findNtfSubscription" st $ \db -> runExceptT $ do - r@(tkn@NtfTknRec {tknStatus}, _) <- - ExceptT $ firstRow (rowToNtfTknMaybeSub q) AUTH $ + tkn@NtfTknRec {ntfTknId, tknStatus} <- ExceptT $ getNtfToken st tknId + unless (allowNtfSubCommands tknStatus) $ throwE AUTH + liftIO $ updateTokenDate st db tkn + sub_ <- + liftIO $ maybeFirstRow (rowToNtfSub q) $ DB.query db [sql| - SELECT t.token_id, t.push_provider, t.push_provider_token, t.status, t.verify_key, t.dh_priv_key, t.dh_secret, t.reg_code, t.cron_interval, t.updated_at, - s.subscription_id, s.smp_notifier_key, s.status - FROM tokens t - LEFT JOIN subscriptions s ON s.token_id = t.token_id AND s.smp_notifier_id = ? - LEFT JOIN smp_servers p ON p.smp_server_id = s.smp_server_id - AND p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? - WHERE t.token_id = ? - |] - (Only nId :. srvToRow srv :. Only tknId) - liftIO $ updateTokenDate st db tkn - unless (allowNtfSubCommands tknStatus) $ throwE AUTH - pure r + SELECT s.token_id, s.subscription_id, s.smp_notifier_key, s.status + FROM subscriptions s + JOIN smp_servers p ON p.smp_server_id = s.smp_server_id + WHERE p.smp_host = ? AND p.smp_port = ? AND p.smp_keyhash = ? + AND s.smp_notifier_id = ? + |] + (smpQueueToRow q) + forM_ sub_ $ \NtfSubRec {tokenId} -> unless (ntfTknId == tokenId) $ throwE AUTH + pure (tkn, sub_) getNtfSubscription :: NtfPostgresStore -> NtfSubscriptionId -> IO (Either ErrorType (NtfTknRec, NtfSubRec)) getNtfSubscription st subId = @@ -313,22 +317,15 @@ getNtfSubscription st subId = type NtfSubRow = (NtfSubscriptionId, NtfPrivateAuthKey, NtfSubStatus) -type MaybeNtfSubRow = (Maybe NtfSubscriptionId, Maybe NtfPrivateAuthKey, Maybe NtfSubStatus) - rowToNtfTknSub :: NtfTknRow :. NtfSubRow :. SMPQueueNtfRow -> (NtfTknRec, NtfSubRec) rowToNtfTknSub (tknRow :. (ntfSubId, notifierKey, subStatus) :. qRow) = let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow smpQueue = rowToSMPQueue qRow in (tkn, NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus}) -rowToNtfTknMaybeSub :: SMPQueueNtf -> NtfTknRow :. MaybeNtfSubRow -> (NtfTknRec, Maybe NtfSubRec) -rowToNtfTknMaybeSub smpQueue (tknRow :. subRow) = - let tkn@NtfTknRec {ntfTknId = tokenId} = rowToNtfTkn tknRow - sub_ = case subRow of - (Just ntfSubId, Just notifierKey, Just subStatus) -> - Just NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} - _ -> Nothing - in (tkn, sub_) +rowToNtfSub :: SMPQueueNtf -> Only NtfTokenId :. NtfSubRow -> NtfSubRec +rowToNtfSub smpQueue (Only tokenId :. (ntfSubId, notifierKey, subStatus)) = + NtfSubRec {ntfSubId, tokenId, smpQueue, notifierKey, subStatus} mkNtfSubRec :: NtfSubscriptionId -> NewNtfEntity 'Subscription -> NtfSubRec mkNtfSubRec ntfSubId (NewNtfSub tokenId smpQueue notifierKey) = diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 64196cf3f..cefe1720b 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -79,6 +79,7 @@ import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NtfSer import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) +import System.Process (callCommand) import Test.Hspec import UnliftIO #if defined(dbPostgres) @@ -569,7 +570,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag threadDelay 500000 suspendAgent alice 0 closeDBStore store - threadDelay 1500000 + callCommand "sync" putStrLn "before opening the database from another agent" -- aliceNtf client doesn't have subscription and is allowed to get notification message @@ -577,7 +578,7 @@ testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {ag (Just SMPMsgMeta {msgFlags = MsgFlags True}) :| _ <- getConnectionMessages aliceNtf [cId] pure () - threadDelay 1500000 + callCommand "sync" putStrLn "after closing the database in another agent" reopenDBStore store foregroundAgent alice diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 8af15aa59..3803e08fa 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -13,7 +13,6 @@ module NtfServerTests where import Control.Concurrent (threadDelay) -import Control.Monad (void) import qualified Data.Aeson as J import qualified Data.Aeson.Types as JT import Data.Bifunctor (first) @@ -52,6 +51,7 @@ ntfServerTests t = do describe "Notifications server protocol syntax" $ ntfSyntaxTests t describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY -- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW + describe "Retried notification subscription" $ testRetriedNtfSubscription t ntfSyntaxTests :: ATransport -> Spec ntfSyntaxTests (ATransport t) = do @@ -179,6 +179,38 @@ testNotificationSubscription (ATransport t) createQueue = smpServer3 `shouldBe` srv notifierId3 `shouldBe` nId +testRetriedNtfSubscription :: ATransport -> Spec +testRetriedNtfSubscription (ATransport t) = + it "should allow retrying to create notification subscription with the same token and key" $ do + g <- C.newRandom + (sPub, _sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + withAPNSMockServer $ \apns -> + smpTest' t $ \h -> + ntfTest t $ \nh -> do + ((_sId, _rId, _rKey, _rcvDhSecret), nId, _rcvNtfDhSecret) <- createNtfQueueNKEY h sPub nPub + (tknKey, _dhSecret, tId, regCode) <- registerToken nh apns "abcd" + let srv = SMPServer SMP.testHost SMP.testPort SMP.testKeyHash + q = SMPQueueNtf srv nId + -- fails creating subscription until token is verified + RespNtf "2" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("2", NoEntity, SNEW $ NewNtfSub tId q nKey) + -- verify token + RespNtf "3" tId1 NROk <- signSendRecvNtf nh tknKey ("3", tId, TVFY regCode) + tId1 `shouldBe` tId + -- create subscription + RespNtf "4" NoEntity (NRSubId subId) <- signSendRecvNtf nh tknKey ("4", NoEntity, SNEW $ NewNtfSub tId q nKey) + -- allow retry + RespNtf "4a" NoEntity (NRSubId subId') <- signSendRecvNtf nh tknKey ("4a", NoEntity, SNEW $ NewNtfSub tId q nKey) + subId' `shouldBe` subId + -- fail with another key + (_nPub, nKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g + RespNtf "5" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey ("5", NoEntity, SNEW $ NewNtfSub tId q nKey') + -- fail with another token + (tknKey', _dhSecret, tId', regCode') <- registerToken nh apns "efgh" + RespNtf "6" _ NROk <- signSendRecvNtf nh tknKey' ("6", tId', TVFY regCode') + RespNtf "7" NoEntity (NRErr AUTH) <- signSendRecvNtf nh tknKey' ("7", NoEntity, SNEW $ NewNtfSub tId' q nKey) + pure () + type CreateQueueFunc = forall c. Transport c => @@ -197,6 +229,24 @@ createNtfQueueNKEY h sPub nPub = do let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey pure ((sId, rId, rKey, rcvDhSecret), nId, rcvNtfDhSecret) +registerToken :: Transport c => THandleNTF c 'TClient -> APNSMockServer -> ByteString -> IO (C.APrivateAuthKey, C.DhSecretX25519, NtfEntityId, NtfRegCode) +registerToken nh apns token = do + g <- C.newRandom + (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + let tkn = DeviceToken PPApnsTest token + RespNtf "1" NoEntity (NRTknId tId ntfDh) <- signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub) + APNSMockRequest {notification = APNSNotification {aps = APNSBackground _, notificationData = Just ntfData}} <- + getMockNotification apns tkn + let dhSecret = C.dh' ntfDh dhPriv + decryptCode nd = + let Right verification = nd .-> "verification" + Right nonce = C.cbNonce <$> nd .-> "nonce" + Right pt = C.cbDecrypt dhSecret nonce verification + in NtfRegCode pt + let code = decryptCode ntfData + pure (tknKey, dhSecret, tId, code) + -- TODO [notifications] -- createNtfQueueNEW :: CreateQueueFunc -- createNtfQueueNEW h sPub nPub = do diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 97470703b..801b7f42e 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -360,6 +360,9 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t > smpTest :: (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () +smpTest' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest' = (`smpTest` ASType SQSMemory SMSJournal) + smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()