refactor auth verification in the server, split tests

2026-04-25 22:52:15 +00:00 · 2024-02-10 10:05:56 +00:00
parent a734c29eeb
commit 0d8a4b86e8
3 changed files with 72 additions and 72 deletions
--- 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"
--- 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
--- 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