diff --git a/plans/2026-10-09-auth-error-delay.md b/plans/2026-10-09-auth-error-delay.md new file mode 100644 index 000000000..5ac82c8e6 --- /dev/null +++ b/plans/2026-10-09-auth-error-delay.md @@ -0,0 +1,52 @@ +# Delayed AUTH error responses + +## Decisions + +- Responses that include `ERR AUTH` are sent at the next multiple of the delay after the start time. +- Delayed response sets: + + | Source | Responses sent together | Start time | + |---|---|---| + | `receive`, failed verification | verification and parsing errors of one received block | block receipt | + | `client`, command processing | responses and messages of one batch | batch read from `rcvQ` | + | `RFWD`, forwarded command | the `RRES` of that command | start of forwarded command processing | + +- A thread created by `forkClient` writes the responses to the send queue. +- Delay 0: the responses are written to the send queue directly. +- `authDelayExceeded`: incremented when processing took longer than the delay. + - Prometheus counter `simplex_smp_auth_delay_exceeded`. + - Not saved in the stats backup. + - Not in the daily stats log. +- Configuration: + + | Item | Value | + |---|---| + | INI section | `TRANSPORT` | + | INI key | `auth_error_delay_ms` | + | default | 50 | + | `ServerConfig` field | `authErrorDelay`, microseconds | + | test servers | 20 ms | + +- AUTH timing test: elapsed time of 5 requests, test servers' delay. +- Out of scope: NTF and XFTP servers. + +## Mechanics + +- `Server.hs`: + - `isAuthError`: response is `ERR AUTH`. + - `sendResponses`: responses with `ERR AUTH` to `sendAfterDelay`, others to the send queue. + - `sendAfterDelay`: writes responses to the send queue at the next multiple of the delay. + - `receive`: block receipt time from the `rcvActiveAt` reading. + - `client`: batch time. + - `processForwardedCommand`: start time. +- `Server/Env/STM.hs`: `authErrorDelay` field, `defaultAuthErrorDelayMs`. +- `Server/Stats.hs`: `authDelayExceeded` in `ServerStats` and `ServerStatsData`. +- `Server/Prometheus.hs`: `simplex_smp_auth_delay_exceeded`. +- `Server/Main.hs`: INI value. +- `Server/Main/Init.hs`: INI template line. +- `simplexmq.cabal`: `timeit` removed from the test suite. +- `tests/SMPClient.hs`: `authErrorDelay = 20000`. +- `tests/ServerTests.hs`: + - delayed AUTH for wrong key, absent queue, absent link and suspended queue; immediate `SOK`. + - AUTH timing test measures elapsed time. +- `tests/SMPProxyTests.hs`: delayed AUTH to forwarded `SEND` and `LGET`. diff --git a/simplexmq.cabal b/simplexmq.cabal index 0153db450..11384f5ae 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -640,7 +640,6 @@ test-suite simplexmq-test , stm , text , time - , timeit ==2.0.* , tls >=1.9.0 && <1.10 , transformers , unliftio diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 600c9d287..e2cef6f50 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1145,14 +1145,16 @@ cancelSub s = case subThread s of type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s) receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s () -receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do +receive h@THandle {params = THandleParams {thAuth, sessionId}} ms c@Client {rcvQ, rcvActiveAt} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" sa <- asks serverActive stats <- asks serverStats + authDelay <- asks $ authErrorDelay . config liftIO $ forever $ do ts <- tGetServer h unlessM (readTVarIO sa) $ throwIO $ userError "server stopped" - atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime + receivedAt <- getSystemTime + atomically $ writeTVar rcvActiveAt $! receivedAt let (es, ts') = partitionEithers $ L.toList ts errs = map (second ERR) es errs' <- case ts' of @@ -1168,7 +1170,7 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds pure $ errs ++ errs' [] -> pure errs - mapM_ (atomically . writeTBQueue sndQ . (,[])) $ L.nonEmpty errs' + mapM_ (sendResponses c stats authDelay receivedAt . (,[])) $ L.nonEmpty errs' where sameParty :: SParty p -> SignedTransmission Cmd -> Bool sameParty p (_, _, (_, _, Cmd p' _)) = isJust $ testEquality p p' @@ -1191,6 +1193,27 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, GET -> incStat $ msgGetAuth stats _ -> pure () +isAuthError :: Transmission BrokerMsg -> Bool +isAuthError (_, _, r) = case r of + ERR AUTH -> True + _ -> False + +sendResponses :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO () +sendResponses c@Client {sndQ} stats authDelay since rs@(ts, _) + | any isAuthError ts = sendAfterDelay c stats authDelay since rs + | otherwise = atomically $ writeTBQueue sndQ rs + +sendAfterDelay :: Client s -> ServerStats -> Int64 -> SystemTime -> (NonEmpty (Transmission BrokerMsg), [Transmission BrokerMsg]) -> IO () +sendAfterDelay c@Client {sndQ, clientTHParams = THandleParams {sessionId}} stats delay since rs + | delay > 0 = do + elapsed <- subtract (microseconds since) . microseconds <$> getSystemTime + when (elapsed >= delay) $ incStat $ authDelayExceeded stats + forkClient c (B.unpack $ "client $" <> encode sessionId <> " auth") $ threadDelay' (delay - elapsed `mod` delay) >> write + | otherwise = write + where + write = atomically $ writeTBQueue sndQ rs + microseconds (MkSystemTime s ns) = s * 1000000 + fromIntegral (ns `div` 1000) + send :: Transport c => MVar (THandleSMP c 'TServer) -> Client s -> IO () send th c@Client {sndQ, msgQ, clientTHParams = THandleParams {sessionId}} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send" @@ -1374,15 +1397,18 @@ client ms clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" + stats <- asks serverStats + authDelay <- asks $ authErrorDelay . config let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams') process batchSubs t acc@(rs, msgs) = (maybe acc (\(!r, !msg_) -> (r : rs, maybe msgs (: msgs) msg_))) <$> processCommand clntServiceId batchSubs t forever $ do batch <- atomically (readTBQueue rcvQ) + processedAt <- liftIO getSystemTime batchSubs <- prepareBatchSubs clntServiceId batch foldrM (process batchSubs) ([], []) batch - >>= \(rs_, msgs) -> mapM_ (atomically . writeTBQueue sndQ . (,msgs)) (L.nonEmpty rs_) + >>= \(rs_, msgs) -> mapM_ (liftIO . sendResponses clnt stats authDelay processedAt . (,msgs)) (L.nonEmpty rs_) where prepareBatchSubs :: Maybe ServiceId -> @@ -2119,6 +2145,7 @@ client processForwardedCommand :: EncFwdTransmission -> M s (Maybe BrokerMsg) processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do + startedAt <- liftIO getSystemTime THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams') sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret' proxyNonce <- liftEitherWith (const CRYPTO) $ C.cbNonce $ bs corrId @@ -2162,7 +2189,11 @@ client _ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing (Right (M.empty, M.empty, M.empty)) t'') stats <- asks serverStats incStat $ pMsgFwdsRecv stats - traverse encodeResp r_ + traverse encodeResp r_ >>= \case + Just rres | any isAuthError r_ -> do + authDelay <- asks $ authErrorDelay . config + Nothing <$ liftIO (sendAfterDelay clnt stats authDelay startedAt ([(corrId, NoEntity, rres)], [])) + rres_ -> pure rres_ where rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s) rejectOrVerify clntThAuth = \case diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index ca59f75f6..2c1843e51 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -68,6 +68,7 @@ module Simplex.Messaging.Server.Env.STM defaultInactiveClientExpiration, defaultProxyClientConcurrency, defaultNameResolverConcurrency, + defaultAuthErrorDelayMs, defaultMaxJournalMsgCount, defaultMaxJournalStateLines, defaultIdleQueueInterval, @@ -187,6 +188,7 @@ data ServerConfig s = ServerConfig ntfDeliveryInterval :: Int, -- | interval between sending pending END events to unsubscribed clients, seconds pendingENDInterval :: Int, + authErrorDelay :: Int64, smpCredentials :: ServerCredentials, httpCredentials :: Maybe ServerCredentials, -- | SMP client-server protocol version range @@ -255,6 +257,9 @@ defaultProxyClientConcurrency = 32 defaultNameResolverConcurrency :: Int defaultNameResolverConcurrency = 1000 +defaultAuthErrorDelayMs :: Int64 +defaultAuthErrorDelayMs = 50 + journalMsgStoreDepth :: Int journalMsgStoreDepth = 5 diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 138a25fc0..4a3c909ed 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -580,6 +580,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = prometheusMetricsFile = combine logPath "smp-server-metrics.txt", pendingENDInterval = 15000000, -- 15 seconds ntfDeliveryInterval = 1500000, -- 1.5 second + authErrorDelay = 1000 * readIniDefault defaultAuthErrorDelayMs "TRANSPORT" "auth_error_delay_ms" ini, smpServerVRange = supportedServerSMPRelayVRange, transportConfig = mkTransportServerConfig diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index 89df1ad93..b82061ca3 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -130,7 +130,9 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = <> ("host = " <> T.pack host <> "\n") <> ("port = " <> defaultServerPorts <> "\n") <> "log_tls_errors = off\n\n\ - \# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\ + \# Minimum time to respond with AUTH error, milliseconds.\n" + <> ("# auth_error_delay_ms = " <> tshow defaultAuthErrorDelayMs <> "\n\n") + <> "# Use `websockets = 443` to run websockets server in addition to plain TLS.\n\ \# This option is deprecated and should be used for testing only.\n\ \# , port 443 should be specified in port above\n\ \websockets = off\n" diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 85d2624fd..864a2014f 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -126,6 +126,7 @@ prometheusMetrics sm rtm ts = _ntfServices, _rcvServicesSubMsg, _rcvServicesSubDuplicate, + _authDelayExceeded, _qCount, _msgCount, _ntfCount, @@ -192,6 +193,10 @@ prometheusMetrics sm rtm ts = \# HELP simplex_smp_queues_notify_monthly Monthly active queues with notifications.\n\ \# TYPE simplex_smp_queues_notify_monthly gauge\n\ \simplex_smp_queues_notify_monthly " <> mstr (monthCount psNtf) <> "\n# monthCountNtf\n\ + \\n\ + \# HELP simplex_smp_auth_delay_exceeded Responses with AUTH errors sent without delay, as processing took longer than the delay.\n\ + \# TYPE simplex_smp_auth_delay_exceeded counter\n\ + \simplex_smp_auth_delay_exceeded " <> mshow _authDelayExceeded <> "\n# authDelayExceeded\n\ \\n" subscriptions = "# Subscriptions\n\ diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql index c39b82990..fcaaf7257 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql @@ -1,6 +1,5 @@ - SET statement_timeout = 0; SET lock_timeout = 0; SET idle_in_transaction_session_timeout = 0; @@ -555,4 +554,3 @@ ALTER TABLE ONLY smp_server.msg_queues - diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index 11a7de666..c1c599822 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -128,6 +128,7 @@ data ServerStats = ServerStats ntfServices :: ServiceStats, rcvServicesSubMsg :: IORef Int, rcvServicesSubDuplicate :: IORef Int, + authDelayExceeded :: IORef Int, qCount :: IORef Int, msgCount :: IORef Int, ntfCount :: IORef Int, @@ -190,6 +191,7 @@ data ServerStatsData = ServerStatsData _rcvServices :: ServiceStatsData, _rcvServicesSubMsg :: Int, _rcvServicesSubDuplicate :: Int, + _authDelayExceeded :: Int, _qCount :: Int, _msgCount :: Int, _ntfCount :: Int, @@ -254,6 +256,7 @@ newServerStats ts = do ntfServices <- newServiceStats rcvServicesSubMsg <- newIORef 0 rcvServicesSubDuplicate <- newIORef 0 + authDelayExceeded <- newIORef 0 qCount <- newIORef 0 msgCount <- newIORef 0 ntfCount <- newIORef 0 @@ -315,6 +318,7 @@ newServerStats ts = do ntfServices, rcvServicesSubMsg, rcvServicesSubDuplicate, + authDelayExceeded, qCount, msgCount, ntfCount, @@ -378,6 +382,7 @@ getServerStatsData s = do _ntfServices <- getServiceStatsData $ ntfServices s _rcvServicesSubMsg <- readIORef $ rcvServicesSubMsg s _rcvServicesSubDuplicate <- readIORef $ rcvServicesSubDuplicate s + _authDelayExceeded <- readIORef $ authDelayExceeded s _qCount <- readIORef $ qCount s _msgCount <- readIORef $ msgCount s _ntfCount <- readIORef $ ntfCount s @@ -439,6 +444,7 @@ getServerStatsData s = do _ntfServices, _rcvServicesSubMsg, _rcvServicesSubDuplicate, + _authDelayExceeded, _qCount, _msgCount, _ntfCount, @@ -503,6 +509,7 @@ setServerStats s d = do setServiceStats (ntfServices s) $! _ntfServices d writeIORef (rcvServicesSubMsg s) $! _rcvServicesSubMsg d writeIORef (rcvServicesSubDuplicate s) $! _rcvServicesSubDuplicate d + writeIORef (authDelayExceeded s) $! _authDelayExceeded d writeIORef (qCount s) $! _qCount d writeIORef (msgCount s) $! _msgCount d writeIORef (ntfCount s) $! _ntfCount d @@ -705,6 +712,7 @@ instance StrEncoding ServerStatsData where _ntfServices, _rcvServicesSubMsg = 0, _rcvServicesSubDuplicate = 0, + _authDelayExceeded = 0, _qCount, _msgCount = 0, _ntfCount = 0, diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index f1d5af1db..2db4a9819 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -263,6 +263,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> prometheusMetricsFile = testPrometheusMetricsFile, pendingENDInterval = 500000, ntfDeliveryInterval = 200000, + authErrorDelay = 20000, smpCredentials = ServerCredentials { caCertificateFile = Just "tests/fixtures/ca.crt", diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 134093acc..62bb4a85e 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -26,7 +26,7 @@ import qualified Data.List.NonEmpty as L import Data.Time.Clock (getCurrentTime) import SMPAgentClient import SMPClient -import ServerTests (decryptMsgV3, sendRecv) +import ServerTests (decryptMsgV3, responseTime, sendRecv) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) @@ -77,6 +77,8 @@ smpProxyTests = do testChangedFwdVersion it "proxy rejects forwarded correlation ID that is not 24 bytes" $ \_ -> testFwdCorrIdSize + it "relay delays AUTH errors to forwarded commands" $ \_ -> + testForwardedAuthErrorDelay describe "deliver message via SMP proxy" $ do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost2 testPort2 testKeyHash @@ -490,6 +492,19 @@ testFwdCorrIdSize = (_, _, reply) <- sendRecv th (Nothing, corrId, SMP.EntityId sessId, SMP.PFWD currentClientSMPRelayVersion cmdPubKey (SMP.EncTransmission "")) reply `shouldBe` Right (SMP.ERR $ SMP.CMD SMP.SYNTAX) +testForwardedAuthErrorDelay :: IO () +testForwardedAuthErrorDelay = + withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) (updateCfg cfgJ2 $ \cfg_ -> cfg_ {authErrorDelay = 500000}) testPort2 $ \_ -> do + g <- C.newRandom + ts <- getCurrentTime + pc <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, testSMPServer, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ()) + sess <- runExceptT' $ connectSMPProxiedRelay pc NRMInteractive testSMPServer2 Nothing + (sendTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxySMPMessage pc NRMInteractive sess Nothing (SMP.EntityId "1234") noMsgFlags "hello" + (getLinkTime, Left (PCEProtocolError SMP.AUTH)) <- responseTime $ runExceptT $ proxyGetSMPQueueLink pc NRMInteractive sess (SMP.EntityId "1234") + sendTime `shouldSatisfy` (>= 0.5) + getLinkTime `shouldSatisfy` (>= 0.5) + -- Shared "phase 2" of the reconnection tests: start a healthy relay, confirm it is reachable -- directly (PING, not via the proxy) so a proxy failure can only mean the proxy didn't reconnect, -- let any stored connection error expire, then require the proxy to establish the session (PKEY). diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 6165dfb46..89ac46144 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -36,6 +36,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.List (isPrefixOf) import Data.Maybe (catMaybes) import Data.String (IsString (..)) +import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Text.Read (readMaybe) import Data.Type.Equality import qualified Data.X509.Validation as XV @@ -58,7 +59,6 @@ import Simplex.Messaging.Transport.Credentials import Simplex.Messaging.Util (whenM) import System.Directory (doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) import System.IO (IOMode (..), withFile) -import System.TimeIt (timeItT) import System.Timeout import Test.HUnit import Test.Hspec hiding (fit, it) @@ -97,6 +97,7 @@ serverTests = do describe "Restore messages (old / v2)" testRestoreExpireMessages describe "Save prometheus metrics" testPrometheusMetrics describe "Timing of AUTH error" testTiming + describe "Delay of AUTH error" testAuthErrorDelay describe "Message notifications" $ do testMessageNotifications testMessageServiceNotifications @@ -1274,21 +1275,21 @@ testTiming = smpTest2Cfg (cfgMS msType) supportedServerSMPRelayVRange t $ \rh sh -> testSameTiming rh sh tst msType where - testName :: (C.AuthAlg, C.AuthAlg, Int) -> String - testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, _) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg] - timingTests :: [(C.AuthAlg, C.AuthAlg, Int)] + testName :: (C.AuthAlg, C.AuthAlg) -> String + testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg] + timingTests :: [(C.AuthAlg, C.AuthAlg)] timingTests = - [ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type - -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150), - -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200), - (C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200), - (C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type - (C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200), - (C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519, 200), - (C.AuthAlg C.SX25519, C.AuthAlg C.SEd448, 150), - (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type + [ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519), -- correct key type + -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448), + -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519), + (C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519), + (C.AuthAlg C.SEd448, C.AuthAlg C.SEd448), -- correct key type + (C.AuthAlg C.SEd448, C.AuthAlg C.SX25519), + (C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519), + (C.AuthAlg C.SX25519, C.AuthAlg C.SEd448), + (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519) -- correct key type ] - timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const + timeRepeat = fmap fst . responseTime . replicateM_ 5 similarTime t1 t2 msType | t1 <= t2 = abs (1 - t1 / t2) < diff | otherwise = similarTime t2 t1 msType @@ -1297,8 +1298,8 @@ testTiming = diff = case msType of ASType SQSPostgres _ -> 0.45 _ -> 0.3 - testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> AStoreType -> Expectation - testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) msType = do + testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg) -> AStoreType -> Expectation + testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg) msType = do g <- C.newRandom (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g @@ -1325,16 +1326,16 @@ testTiming = runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> EntityId -> Command p -> IO () runTimingTest h badKey qId cmd = do threadDelay 100000 - _ <- timeRepeat n $ do + _ <- timeRepeat $ do -- "warm up" the server Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd) return () threadDelay 100000 - timeWrongKey <- timeRepeat n $ do + timeWrongKey <- timeRepeat $ do Resp "cdabcdabcdabcdabcdabcdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdabcdabcdabcdabcdabcdab", qId, cmd) return () threadDelay 100000 - timeNoQueue <- timeRepeat n $ do + timeNoQueue <- timeRepeat $ do Resp "dabcdabcdabcdabcdabcdabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabcdabcdabcdabcdabcdabc", EntityId "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey msType @@ -1347,6 +1348,33 @@ testTiming = ] ok `shouldBe` True +testAuthErrorDelay :: SpecWith (ASrvTransport, AStoreType) +testAuthErrorDelay = + it "should send AUTH errors after the delay and other responses without it" $ \(ATransport t, msType) -> + smpTest2Cfg (updateCfg (cfgMS msType) $ \cfg' -> cfg' {authErrorDelay = 500000}) supportedClientSMPRelayVRange t $ \rh sh -> do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + Resp "1" NoEntity (Ids rId sId _) <- signSendRecv rh rKey ("1", NoEntity, New rPub dhPub) + (_, badKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (wrongKeyTime, Resp "2" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("2", rId, SUB) + (noQueueTime, Resp "3" _ (ERR AUTH)) <- responseTime $ signSendRecv rh badKey ("3", EntityId "1234", SUB) + (noLinkTime, Resp "4" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "4", EntityId "1234", LGET) + (subTime, Resp "5" _ (SOK Nothing)) <- responseTime $ signSendRecv rh rKey ("5", rId, SUB) + Resp "6" _ OK <- signSendRecv rh rKey ("6", rId, OFF) + (suspendedTime, Resp "7" _ (ERR AUTH)) <- responseTime $ sendRecv sh ("", "7", sId, _SEND "hello") + wrongKeyTime `shouldSatisfy` (>= 0.5) + noQueueTime `shouldSatisfy` (>= 0.5) + suspendedTime `shouldSatisfy` (>= 0.5) + noLinkTime `shouldSatisfy` (>= 0.5) + subTime `shouldSatisfy` (< 0.5) + +responseTime :: IO a -> IO (NominalDiffTime, a) +responseTime action = do + t <- getCurrentTime + r <- action + (,r) . (`diffUTCTime` t) <$> getCurrentTime + testMessageNotifications :: SpecWith (ASrvTransport, AStoreType) testMessageNotifications = it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do