Prekeys investigation: test

changelog.d/5-internal/pr-2694

@@ -0,0 +1 @@
+Add two integration tests arounds last prekeys

libs/wire-api/src/Wire/API/User/Client/Prekey.hs

@@ -25,6 +25,7 @@ module Wire.API.User.Client.Prekey
     LastPrekey,
     lastPrekey,
     unpackLastPrekey,
+    fakeLastPrekey,
     lastPrekeyId,
     PrekeyBundle (..),
     ClientPrekey (..),
@@ -101,6 +102,11 @@ lastPrekeyId = PrekeyId maxBound
 lastPrekey :: Text -> LastPrekey
 lastPrekey = LastPrekey . Prekey lastPrekeyId
 
+-- for tests only
+-- This fake last prekey has the wrong prekeyId
+fakeLastPrekey :: LastPrekey
+fakeLastPrekey = LastPrekey $ Prekey (PrekeyId 7) "pQABAQcCoQBYIDXdN8VlKb5lbgPmoDPLPyqNIEyShG4oT/DlW0peRRZUA6EAoQBYILLf1TIwSB62q69Ojs/X1tzJ+dYHNAw4QbW/7TC5vSZqBPY="
+
 --------------------------------------------------------------------------------
 -- PrekeyBundle
 

services/brig/src/Brig/App.hs

@@ -232,8 +232,12 @@ newEnv o = do
     SqsQueue q -> SqsQueue <$> AWS.getQueueUrl (aws ^. AWS.amazonkaEnv) q
   mSFTEnv <- mapM Calling.mkSFTEnv $ Opt.sft o
   prekeyLocalLock <- case Opt.randomPrekeys o of
-    Just True -> Just <$> newMVar ()
-    _ -> pure Nothing
+    Just True -> do
+      Log.info lgr $ Log.msg (Log.val "randomPrekeys: active")
+      Just <$> newMVar ()
+    _ -> do
+      Log.info lgr $ Log.msg (Log.val "randomPrekeys: not active; using dynamoDB instead.")
+      pure Nothing
   kpLock <- newMVar ()
   pure $!
     Env

services/brig/test/integration/API/User/Client.hs

@@ -50,6 +50,7 @@ import Data.Text.Ascii (AsciiChars (validate))
 import qualified Data.Vector as Vec
 import Imports
 import qualified Network.Wai.Utilities.Error as Error
+import qualified System.Logger as Log
 import Test.QuickCheck (arbitrary, generate)
 import Test.Tasty hiding (Timeout)
 import Test.Tasty.Cannon hiding (Cannon)
@@ -103,6 +104,9 @@ tests _cl _at opts p db b c g =
       test p "get /clients - 200" $ testListClients b,
       test p "get /clients/:client/prekeys - 200" $ testListPrekeyIds b,
       test p "post /clients - 400" $ testTooManyClients opts b,
+      test p "client/prekeys not empty" $ testPrekeysNotEmptyRandomPrekeys opts b,
+      test p "lastprekeys not bogus" $ testRegularPrekeysCannotBeSentAsLastPrekeys b,
+      test p "lastprekeys not bogus during update" $ testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate b,
       test p "delete /clients/:client - 200 (pwd)" $ testRemoveClient True b c,
       test p "delete /clients/:client - 200 (no pwd)" $ testRemoveClient False b c,
       test p "delete /clients/:client - 400 (short pwd)" $ testRemoveClientShortPwd b,
@@ -689,6 +693,61 @@ testTooManyClients opts brig = do
       const (Just "too-many-clients") === fmap Error.label . responseJsonMaybe
       const (Just "application/json") === getHeader "Content-Type"
 
+-- Ensure that the list of prekeys for a user does not become empty, and the
+-- last resort prekey keeps being returned if it's the only key left.
+-- Test with featureFlag randomPrekeys=true
+testPrekeysNotEmptyRandomPrekeys :: Opt.Opts -> Brig -> Http ()
+testPrekeysNotEmptyRandomPrekeys opts brig = do
+  -- Run the test for randomPrekeys (not dynamoDB locking)
+  let newOpts = opts {Opt.randomPrekeys = Just True}
+  ensurePrekeysNotEmpty newOpts brig
+
+ensurePrekeysNotEmpty :: Opt.Opts -> Brig -> Http ()
+ensurePrekeysNotEmpty opts brig = withSettingsOverrides opts $ do
+  lgr <- Log.new Log.defSettings
+  uid <- userId <$> randomUser brig
+  -- Create a client with 1 regular prekey and 1 last resort prekey
+  c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [somePrekeys !! 10] (someLastPrekeys !! 10))
+  -- Claim the first regular one
+  _rs1 <- getPreKey brig uid uid (clientId c) <!! const 200 === statusCode
+  -- Claim again; this should give the last resort one
+  rs2 <- getPreKey brig uid uid (clientId c) <!! const 200 === statusCode
+  let pId2 = prekeyId . prekeyData <$> responseJsonMaybe rs2
+  liftIO $ assertEqual "last prekey rs2" (Just lastPrekeyId) pId2
+  liftIO $ Log.warn lgr (Log.msg (Log.val "First claim of last resort successful, claim again..."))
+  -- Claim again; this should (again) give the last resort one
+  rs3 <- getPreKey brig uid uid (clientId c) <!! const 200 === statusCode
+  let pId3 = prekeyId . prekeyData <$> responseJsonMaybe rs3
+  liftIO $ assertEqual "last prekey rs3" (Just lastPrekeyId) pId3
+
+testRegularPrekeysCannotBeSentAsLastPrekeys :: Brig -> Http ()
+testRegularPrekeysCannotBeSentAsLastPrekeys brig = do
+  uid <- userId <$> randomUser brig
+  -- The parser should reject a normal prekey in the lastPrekey field
+  addClient brig uid (defNewClient PermanentClientType [head somePrekeys] fakeLastPrekey) !!! const 400 === statusCode
+
+testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate :: Brig -> Http ()
+testRegularPrekeysCannotBeSentAsLastPrekeysDuringUpdate brig = do
+  uid <- userId <$> randomUser brig
+  c <- responseJsonError =<< addClient brig uid (defNewClient PermanentClientType [head somePrekeys] (someLastPrekeys !! 11)) <!! const 201 === statusCode
+  let newPrekey = somePrekeys !! 2
+  let update =
+        defUpdateClient
+          { updateClientPrekeys = [newPrekey],
+            updateClientLastKey = Just fakeLastPrekey,
+            updateClientLabel = Just "label"
+          }
+  -- The parser should reject a normal prekey in the lastPrekey field
+  put
+    ( brig
+        . paths ["clients", toByteString' (clientId c)]
+        . zUser uid
+        . contentJson
+        . body (RequestBodyLBS $ encode update)
+    )
+    !!! const 400
+      === statusCode
+
 -- @END
 
 -- The testRemoveClient test conforms to the following testing standards:

services/brig/test/integration/Util.hs

@@ -687,7 +687,13 @@ defNewClientWithVerificationCode mbCode ty pks lpk =
       newClientVerificationCode = mbCode
     }
 
-getPreKey :: Brig -> UserId -> UserId -> ClientId -> Http ResponseLBS
+getPreKey ::
+  (MonadIO m, MonadCatch m, MonadFail m, MonadHttp m, HasCallStack) =>
+  Brig ->
+  UserId ->
+  UserId ->
+  ClientId ->
+  m ResponseLBS
 getPreKey brig zusr u c =
   get $
     apiVersion "v1"