integration: Add test to ensure temp notif queues are deleted

Also:
- Extract function to create RabbitMQAdminClient for a backend resource
- Extract function to runDynamicBackends returning the BackendResources instead
of returning just the domains.

integration/default.nix

@@ -64,6 +64,8 @@
 , retry
 , saml2-web-sso
 , scientific
+, servant
+, servant-client
 , split
 , stm
 , streaming-commons
@@ -161,6 +163,8 @@ mkDerivation {
     retry
     saml2-web-sso
     scientific
+    servant
+    servant-client
     split
     stm
     streaming-commons

integration/integration.cabal

@@ -259,6 +259,8 @@ library
     , retry
     , saml2-web-sso
     , scientific
+    , servant
+    , servant-client
     , split
     , stm
     , streaming-commons

integration/test/SetupHelpers.hs

@@ -36,6 +36,7 @@ import SAML2.WebSSO.Test.Util (SampleIdP (..), makeSampleIdPMetadata)
 import Testlib.JSON
 import Testlib.MockIntegrationService (mkLegalHoldSettings)
 import Testlib.Prelude
+import Testlib.Printing (indent)
 import qualified Text.XML as XML
 import qualified Text.XML.Cursor as XML
 import qualified Text.XML.DSig as SAML
@@ -426,6 +427,12 @@ addUsersToFailureContext namesAndUsers action = do
   allLines <- unlines <$> (mapM mkLine namesAndUsers)
   addFailureContext allLines action
 
+addJSONToFailureContext :: (MakesValue a) => String -> a -> App b -> App b
+addJSONToFailureContext name ctx action = do
+  jsonStr <- prettyJSON ctx
+  let ctxStr = unlines [name <> ":", indent 2 jsonStr]
+  addFailureContext ctxStr action
+
 registerTestIdPWithMeta :: (HasCallStack, MakesValue owner) => owner -> App Response
 registerTestIdPWithMeta owner = fst <$> registerTestIdPWithMetaWithPrivateCreds owner
 

integration/test/Test/Events.hs

@@ -11,16 +11,19 @@ import Control.Monad.RWS (asks)
 import Control.Monad.Trans.Class
 import Control.Retry
 import Data.ByteString.Conversion (toByteString')
+import Data.Proxy (Proxy (..))
 import qualified Data.Text as Text
 import Data.Timeout
 import MLS.Util
 import Network.AMQP.Extended
 import Network.RabbitMqAdmin
 import qualified Network.WebSockets as WS
 import Notifications
+import Servant.API (AsApi, ToServant, toServant)
+import Servant.API.Generic (fromServant)
+import qualified Servant.Client as Servant
 import SetupHelpers
 import Testlib.Prelude hiding (assertNoEvent)
-import Testlib.ResourcePool (acquireResources)
 import UnliftIO hiding (handle)
 
 testConsumeEventsOneWebSocket :: (HasCallStack) => App ()
@@ -119,6 +122,37 @@ testConsumeTempEventsWithoutOwnClient = do
 
       ackEvent ws e
 
+testTemporaryQueuesAreDeletedAfterUse :: (HasCallStack) => App ()
+testTemporaryQueuesAreDeletedAfterUse = do
+  startDynamicBackendsReturnResources [def] $ \[beResource] -> do
+    let domain = beResource.berDomain
+    rabbitmqAdmin <- mkRabbitMqAdminClientForResource beResource
+    queuesBeforeWS <- rabbitmqAdmin.listQueuesByVHost (fromString beResource.berVHost) (fromString "") True 100 1
+    let deadNotifsQueue = Queue {name = fromString "dead-user-notifications", vhost = fromString beResource.berVHost}
+    queuesBeforeWS.items `shouldMatch` [deadNotifsQueue]
+
+    [alice, bob] <- createAndConnectUsers [domain, domain]
+
+    runCodensity (createEventsWebSocket alice Nothing) $ \ws -> do
+      handle <- randomHandle
+      putHandle bob handle >>= assertSuccess
+
+      queuesDuringWS <- rabbitmqAdmin.listQueuesByVHost (fromString beResource.berVHost) (fromString "") True 100 1
+      addJSONToFailureContext "queuesDuringWS" queuesDuringWS $ do
+        length queuesDuringWS.items `shouldMatchInt` 2
+
+      void $ assertEvent ws $ \e -> do
+        e %. "type" `shouldMatch` "event"
+        e %. "data.event.payload.0.type" `shouldMatch` "user.update"
+        e %. "data.event.payload.0.user.id" `shouldMatch` objId bob
+        e %. "data.event.payload.0.user.handle" `shouldMatch` handle
+
+        ackEvent ws e
+
+    -- Use let binding here so 'shouldMatchEventually' retries the whole request
+    let queuesAfterWSM = rabbitmqAdmin.listQueuesByVHost (fromString beResource.berVHost) (fromString "") True 100 1
+    fmap (.items) queuesAfterWSM `shouldEventuallyMatch` ([deadNotifsQueue])
+
 testMLSTempEvents :: (HasCallStack) => App ()
 testMLSTempEvents = do
   [alice, bob] <- createAndConnectUsers [OwnDomain, OwnDomain]
@@ -429,22 +463,17 @@ testChannelLimit = withModifiedBackend
         lift $ assertNoEvent_ ws
 
 testChannelKilled :: (HasCallStack) => App ()
-testChannelKilled = lowerCodensity $ do
-  pool <- lift $ asks (.resourcePool)
-  [backend] <- acquireResources 1 pool
-
-  domain <- startDynamicBackend backend mempty
-  alice <- lift $ randomUser domain def
+testChannelKilled = startDynamicBackendsReturnResources [def] $ \[backend] -> do
+  let domain = backend.berDomain
+  alice <- randomUser domain def
   [c1, c2] <-
-    lift
-      $ replicateM 2
+    replicateM 2
       $ addClient alice def {acapabilities = Just ["consumable-notifications"]}
       >>= getJSON 201
       >>= (%. "id")
       >>= asString
 
-  ws <- createEventsWebSocket alice (Just c1)
-  lift $ do
+  runCodensity (createEventsWebSocket alice (Just c1)) $ \ws -> do
     assertEvent ws $ \e -> do
       e %. "data.event.payload.0.type" `shouldMatch` "user.client-add"
       e %. "data.event.payload.0.client.id" `shouldMatch` c1
@@ -592,6 +621,16 @@ consumeAllEvents ws = do
 
 killConnection :: (HasCallStack) => BackendResource -> App ()
 killConnection backend = do
+  rabbitmqAdminClient <- mkRabbitMqAdminClientForResource backend
+  connections <- rabbitmqAdminClient.listConnectionsByVHost (Text.pack backend.berVHost)
+  connection <-
+    assertOne
+      [ c | c <- connections, c.userProvidedName == Just (Text.pack "pool 0")
+      ]
+  void $ rabbitmqAdminClient.deleteConnection connection.name
+
+mkRabbitMqAdminClientForResource :: BackendResource -> App (AdminAPI (Servant.AsClientT App))
+mkRabbitMqAdminClientForResource backend = do
   rc <- asks (.rabbitMQConfig)
   let opts =
         RabbitMqAdminOpts
@@ -605,12 +644,4 @@ killConnection backend = do
                 else Nothing
           }
   servantClient <- liftIO $ mkRabbitMqAdminClientEnv opts
-  name <- do
-    connections <- liftIO $ listConnectionsByVHost servantClient opts.vHost
-    connection <-
-      assertOne
-        [ c | c <- connections, c.userProvidedName == Just (Text.pack "pool 0")
-        ]
-    pure connection.name
-
-  void $ liftIO $ deleteConnection servantClient name
+  pure . fromServant $ Servant.hoistClient (Proxy @(ToServant AdminAPI AsApi)) (liftIO @App) (toServant servantClient)

integration/test/Testlib/Assertions.hs

@@ -7,7 +7,9 @@ import Control.Exception as E
 import Control.Lens ((^?))
 import qualified Control.Lens.Plated as LP
 import Control.Monad
+import qualified Control.Monad.Catch as Catch
 import Control.Monad.Reader
+import Control.Retry
 import Data.Aeson (Value)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Diff as AD
@@ -62,6 +64,15 @@ shouldMatch ::
   App ()
 shouldMatch = shouldMatchWithMsg Nothing
 
+-- | Retries every 100ms until timeOutSeconds from Env is reached
+shouldEventuallyMatch :: (MakesValue a, MakesValue b, HasCallStack) => a -> b -> App ()
+shouldEventuallyMatch a b = do
+  timeout <- asks (.timeOutSeconds)
+  recovering
+    (limitRetriesByCumulativeDelay (timeout * 1_000_000) $ constantDelay 100_000)
+    ((\_ -> Catch.Handler $ \(_ :: AssertionFailure) -> pure True) : skipAsyncExceptions)
+    (const $ a `shouldMatch` b)
+
 shouldMatchWithMsg ::
   (MakesValue a, MakesValue b, HasCallStack) =>
   -- | Message to be added to failure report

integration/test/Testlib/ModService.hs

@@ -4,6 +4,7 @@ module Testlib.ModService
   ( withModifiedBackend,
     startDynamicBackend,
     startDynamicBackends,
+    startDynamicBackendsReturnResources,
     traverseConcurrentlyCodensity,
   )
 where
@@ -120,6 +121,10 @@ traverseConcurrentlyCodensity f args = do
 
 startDynamicBackends :: [ServiceOverrides] -> ([String] -> App a) -> App a
 startDynamicBackends beOverrides k = do
+  startDynamicBackendsReturnResources beOverrides (\resources -> k $ map (.berDomain) resources)
+
+startDynamicBackendsReturnResources :: [ServiceOverrides] -> ([BackendResource] -> App a) -> App a
+startDynamicBackendsReturnResources beOverrides k = do
   let startDynamicBackendsCodensity = do
         when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
         pool <- asks (.resourcePool)
@@ -128,7 +133,7 @@ startDynamicBackends beOverrides k = do
           traverseConcurrentlyCodensity
             (void . uncurry startDynamicBackend)
             (zip resources beOverrides)
-        pure $ map (.berDomain) resources
+        pure resources
   runCodensity startDynamicBackendsCodensity k
 
 startDynamicBackend :: (HasCallStack) => BackendResource -> ServiceOverrides -> Codensity App String