diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index b76b0d0d0..22717521f 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -466,13 +466,21 @@ disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcv data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed +-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios: +-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key. +-- - the queue and party key exist, but the provided authorization has incorrect type. +-- - the queue or party key do not exist. +-- In all cases, the time of the verification should depend only on the provided authorization type, +-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient + -- SEND will be accepted without authorization before the queue is secured with KEY command Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing + -- NSUB will not be accepted without authorization Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier where verify = verifyCmdAuthorization auth_ tAuth authorized @@ -529,7 +537,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" dummyKeyX25519 :: C.PublicKey 'C.X25519 -dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas_jHeBwfcM7jLwNYJNOAhi2_g4RXg=" +dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg=" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index c5bfa02c4..372c2b242 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -57,7 +57,7 @@ serverTests t@(ATransport t') = do describe "Store log" $ testWithStoreLog t describe "Restore messages" $ testRestoreMessages t describe "Restore messages (old / v2)" $ testRestoreExpireMessages t - fdescribe "Timing of AUTH error" $ testTiming t + describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do testMsgExpireOnSend t' @@ -738,24 +738,28 @@ createAndSecureQueue h sPub = do testTiming :: ATransport -> Spec testTiming (ATransport t) = - describe "should have similar time for auth error, whether queue exists or not, for all key sizes" $ - forM_ timingTests $ \tst -> it (testName tst) $ - smpTest2Cfg cfgV8 (mkVersionRange 4 authEncryptCmdsSMPVersion) t $ \rh sh -> - testSameTiming rh sh tst + describe "should have similar time for auth error, whether queue exists or not, for all key types" $ + forM_ timingTests $ \tst -> + it (testName tst) $ + smpTest2Cfg cfgV8 (mkVersionRange 4 authEncryptCmdsSMPVersion) t $ \rh sh -> + testSameTiming rh sh tst 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)] timingTests = - [ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 300), - (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150), - (C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 300), - (C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150) + [ (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.SX25519, C.AuthAlg C.SX25519, 300) - -- ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.1 + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.12 -- normally the difference between "no queue" and "wrong key" is less than 5% testSameTiming :: forall c. Transport c => THandle c -> THandle c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom @@ -780,7 +784,7 @@ testTiming (ATransport t) = runTimingTest :: PartyI p => THandle c -> C.APrivateAuthKey -> ByteString -> Command p -> IO () runTimingTest h badKey qId cmd = do threadDelay 100000 - _ <- timeRepeat n $ do + _ <- timeRepeat n $ do -- "warm up" the server Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) return () threadDelay 100000 @@ -792,7 +796,7 @@ testTiming (ATransport t) = Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey - putStrLn . unwords $ + unless ok . putStrLn . unwords $ [ show goodKeyAlg, show badKeyAlg, show timeWrongKey,