diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index b79398bdd..b76b0d0d0 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -469,47 +469,34 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed 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 `verified` verifyCmdAuthorization auth_ tAuth authorized k - Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdAuthorization auth_ tAuth authorized . recipientKey - Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey + Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient + Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing - Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier + Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier where - verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult - verifyCmd party f = do - st <- asks queueStore - q_ <- atomically $ getQueue st party queueId - pure $ case q_ of - Right q -> Just q `verified` f q - _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed - verifyMaybe :: Maybe C.APublicAuthKey -> Bool - verifyMaybe = maybe (isNothing tAuth) $ verifyCmdAuthorization auth_ tAuth authorized + verify = verifyCmdAuthorization auth_ tAuth authorized + dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed + verifyQueue :: (QueueRec -> VerificationResult) -> Either ErrorType QueueRec -> VerificationResult + verifyQueue = either (\_ -> dummyVerify) verified q cond = if cond then VRVerified q else VRFailed + verifiedWith q k = q `verified` verify k + get :: SParty p -> M (Either ErrorType QueueRec) + get party = do + st <- asks queueStore + atomically $ getQueue st party queueId verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth - -- TANone -> False - -- TASignature sig -> verifySig key sig - -- TAAuthenticator s -> verifyAuth key s where verify :: C.APublicAuthKey -> TransmissionAuth -> Bool verify (C.APublicAuthKey a k) = \case - TASignature sig@(C.ASignature a' s) -> case testEquality a a' of - Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized - _ -> dummyVerifyCmd auth_ authorized (TASignature sig) `seq` False + TASignature (C.ASignature a' s) -> case testEquality a a' of + Just Refl -> C.verify' k s authorized + _ -> C.verify' (dummySignKey a') s authorized `seq` False TAAuthenticator s -> case a of C.SX25519 -> verifyCmdAuth auth_ k s authorized - _ -> dummyVerifyCmd auth_ authorized (TAAuthenticator s) `seq` False - -- verifySig :: C.APublicAuthKey -> C.ASignature -> Bool - -- verifySig (C.APublicAuthKey a k) sig@(C.ASignature a' s) = - -- case testEquality a a' of - -- Just Refl | C.signatureSize k == C.signatureSize s -> C.verify' k s authorized - -- _ -> dummyVerifyCmd auth_ authorized (TASignature sig) `seq` False - -- verifyAuth :: C.APublicAuthKey -> C.CbAuthenticator -> Bool - -- verifyAuth (C.APublicAuthKey a k) s = - -- case a of - -- C.SX25519 -> verifyCmdAuth auth_ k s authorized - -- _ -> dummyVerifyCmd auth_ authorized (TAAuthenticator s) `seq` False + _ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool verifyCmdAuth auth_ k authenticator authorized = case auth_ of @@ -518,17 +505,22 @@ verifyCmdAuth auth_ k authenticator authorized = case auth_ of dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool dummyVerifyCmd auth_ authorized = \case - TASignature (C.ASignature a s) -> C.verify' (dummyPublicKey a) s authorized + TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes -dummyPublicKey :: C.SAlgorithm a -> C.PublicKey a -dummyPublicKey = \case +dummySignKey :: C.SignatureAlgorithm a => C.SAlgorithm a -> C.PublicKey a +dummySignKey = \case C.SEd25519 -> dummyKeyEd25519 C.SEd448 -> dummyKeyEd448 - C.SX25519 -> dummyKeyX25519 - C.SX448 -> dummyKeyX448 + +dummyAuthKey :: Maybe TransmissionAuth -> C.APublicAuthKey +dummyAuthKey = \case + Just (TASignature (C.ASignature a _)) -> case a of + C.SEd25519 -> C.APublicAuthKey C.SEd25519 dummyKeyEd25519 + C.SEd448 -> C.APublicAuthKey C.SEd448 dummyKeyEd448 + _ -> C.APublicAuthKey C.SX25519 dummyKeyX25519 dummyKeyEd25519 :: C.PublicKey 'C.Ed25519 dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" @@ -539,9 +531,6 @@ dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/Xo dummyKeyX25519 :: C.PublicKey 'C.X25519 dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas_jHeBwfcM7jLwNYJNOAhi2_g4RXg=" -dummyKeyX448 :: C.PublicKey 'C.X448 -dummyKeyX448 = "MEIwBQYDK2VvAzkAs6Z2fErHib1C2QfKcrDeNlfi8Xtb1UTWF-slWubEmfbk0M0N-qh9A2JBNZebrVUMW4--skAjJ3I=" - 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 labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 67396c35b..f5857f23b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -26,7 +26,7 @@ import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.Server -import Simplex.Messaging.Version (mkVersionRange) +import Simplex.Messaging.Version (VersionRange, mkVersionRange) import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -68,12 +68,15 @@ xit'' d t = do (if ci == Just "true" then xit else it) d t testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a -testSMPClient client = do +testSMPClient = testSMPClientVR supportedClientSMPRelayVRange + +testSMPClientVR :: (Transport c, MonadUnliftIO m, MonadFail m) => VersionRange -> (THandle c -> m a) -> m a +testSMPClientVR vr client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do g <- liftIO C.newRandom ks <- atomically $ C.generateKeyPair g - liftIO (runExceptT $ smpClientHandshake h ks testKeyHash supportedClientSMPRelayVRange) >>= \case + liftIO (runExceptT $ smpClientHandshake h ks testKeyHash vr) >>= \case Right th -> client th Left e -> error $ show e @@ -149,11 +152,14 @@ runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandl runSmpTest test = withSmpServer (transport @c) $ testSMPClient test runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO a) -> IO a -runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients [] +runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange + +runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRange -> Int -> (HasCallStack => [THandle c] -> IO a) -> IO a +runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients [] where run :: Int -> [THandle c] -> IO a run 0 hs = test hs - run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) + run n hs = testSMPClientVR clntVR $ \h -> run (n - 1) (h : hs) smpServerTest :: forall c smp. @@ -179,7 +185,10 @@ smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] - smpTestN n test' = runSmpTestN n test' `shouldReturn` () smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation -smpTest2 _ test' = smpTestN 2 _test +smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange + +smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRange -> TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation +smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` () where _test :: HasCallStack => [THandle c] -> IO () _test [h1, h2] = test' h1 h2 diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 2a94de790..ceb48bdca 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -33,6 +33,7 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Transport +import Simplex.Messaging.Version (mkVersionRange) import System.Directory (removeFile) import System.TimeIt (timeItT) import System.Timeout @@ -56,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 - describe "Timing of AUTH error" $ testTiming t + fdescribe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do testMsgExpireOnSend t' @@ -87,7 +88,7 @@ signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do authorize t = case a of C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t - _ -> Nothing + C.SX25519 -> (\THandleAuth {peerPubKey} -> TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t) <$> thAuth params tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) tPut1 h t = do @@ -737,32 +738,38 @@ createAndSecureQueue h sPub = do testTiming :: ATransport -> Spec testTiming (ATransport t) = - it "should have similar time for auth error, whether queue exists or not, for all key sizes" $ - smpTest2 t $ \rh sh -> - mapM_ (testSameTiming rh sh) timingTests + 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 where - timingTests :: [(Int, Int, Int)] + 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 = - [ (32, 32, 300), - (32, 57, 150), - (57, 32, 300), - (57, 57, 150) + [ (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.SX25519, C.AuthAlg C.SX25519, 300) + -- ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 - testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation - testSameTiming rh sh (goodKeySize, badKeySize, n) = do + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.05 + testSameTiming :: Transport c => THandle c -> THandle c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation + testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do + threadDelay 500000 g <- C.newRandom - (rPub, rKey) <- generateKeys g goodKeySize + (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) - (_, badKey) <- generateKeys g badKeySize + (_, badKey) <- atomically $ C.generateAuthKeyPair badKeyAlg g -- runTimingTest rh badKey rId "SUB" - (sPub, sKey) <- generateKeys g goodKeySize + (sPub, sKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello") @@ -771,10 +778,6 @@ testTiming (ATransport t) = runTimingTest sh badKey sId $ _SEND "hello" where - generateKeys g = \case - 32 -> atomically $ C.generateAuthKeyPair C.SEd25519 g - 57 -> atomically $ C.generateAuthKeyPair C.SEd448 g - _ -> error "unsupported key size" runTimingTest h badKey qId cmd = do threadDelay 100000 timeWrongKey <- timeRepeat n $ do @@ -785,14 +788,13 @@ testTiming (ATransport t) = Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey - unless ok $ - (putStrLn . unwords . map show) - [ fromIntegral goodKeySize, - fromIntegral badKeySize, - timeWrongKey, - timeNoQueue, - abs (timeWrongKey / timeNoQueue - 1) - ] + unless ok . putStrLn . unwords $ + [ show goodKeyAlg, + show badKeyAlg, + show timeWrongKey, + show timeNoQueue, + show $ timeWrongKey / timeNoQueue - 1 + ] ok `shouldBe` True testMessageNotifications :: ATransport -> Spec