Add more call HasCallStack constraints to functions in test suite (#3500

)
wireapp · Aug 14, 2023 · a2b5594 · a2b5594
1 parent 26f1a98
commit a2b5594
Show file tree

Hide file tree

Showing 3 changed files with 18 additions and 12 deletions.
diff --git a/integration/test/Testlib/App.hs b/integration/test/Testlib/App.hs
@@ -8,13 +8,14 @@ import Data.IORef
 import Data.Text qualified as T
 import Data.Yaml qualified as Yaml
 import GHC.Exception
+import GHC.Stack (HasCallStack)
 import System.FilePath
 import Testlib.Env
 import Testlib.JSON
 import Testlib.Types
 import Prelude
 
-failApp :: String -> App a
+failApp :: HasCallStack => String -> App a
 failApp msg = throw (AppFailure msg)
 
 getPrekey :: App Value

diff --git a/integration/test/Testlib/ModService.hs b/integration/test/Testlib/ModService.hs
@@ -83,8 +83,8 @@ copyDirectoryRecursively from to = do
 -- continuation, the main continuation is run in an environment that
 -- accumulates all the individual environment changes.
 traverseConcurrentlyCodensity ::
-  (a -> Codensity App (Env -> Env)) ->
-  ([a] -> Codensity App (Env -> Env))
+  (HasCallStack => a -> Codensity App (Env -> Env)) ->
+  (HasCallStack => [a] -> Codensity App (Env -> Env))
 traverseConcurrentlyCodensity f args = do
   -- Create variables for synchronisation of the various threads:
   --  * @result@ is used to store the environment change, or possibly an exception
@@ -138,15 +138,19 @@ traverseConcurrentlyCodensity f args = do
     liftIO $ traverse_ wait asyncs
     pure result
 
-startDynamicBackends :: [ServiceOverrides] -> ([String] -> App a) -> App a
-startDynamicBackends beOverrides = runCodensity $ do
-  when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
-  pool <- asks (.resourcePool)
-  resources <- acquireResources (Prelude.length beOverrides) pool
-  void $ traverseConcurrentlyCodensity (\(res, overrides) -> startDynamicBackend res mempty overrides) (zip resources beOverrides)
-  pure $ map (.berDomain) resources
+startDynamicBackends :: HasCallStack => [ServiceOverrides] -> (HasCallStack => [String] -> App a) -> App a
+startDynamicBackends beOverrides k =
+  runCodensity
+    ( do
+        when (Prelude.length beOverrides > 3) $ lift $ failApp "Too many backends. Currently only 3 are supported."
+        pool <- asks (.resourcePool)
+        resources <- acquireResources (Prelude.length beOverrides) pool
+        void $ traverseConcurrentlyCodensity (\(res, overrides) -> startDynamicBackend res mempty overrides) (zip resources beOverrides)
+        pure $ map (.berDomain) resources
+    )
+    k
 
-startDynamicBackend :: BackendResource -> Map.Map Service Word16 -> ServiceOverrides -> Codensity App (Env -> Env)
+startDynamicBackend :: HasCallStack => BackendResource -> Map.Map Service Word16 -> ServiceOverrides -> Codensity App (Env -> Env)
 startDynamicBackend resource staticPorts beOverrides = do
   defDomain <- asks (.domain1)
   let services =

diff --git a/integration/test/Testlib/ResourcePool.hs b/integration/test/Testlib/ResourcePool.hs
@@ -21,6 +21,7 @@ import Data.String
 import Data.Tuple
 import Data.Word
 import GHC.Generics
+import GHC.Stack (HasCallStack)
 import System.IO
 import Prelude
 
@@ -29,7 +30,7 @@ data ResourcePool a = ResourcePool
     resources :: IORef (Set.Set a)
   }
 
-acquireResources :: forall m a. (Ord a, MonadIO m, MonadMask m) => Int -> ResourcePool a -> Codensity m [a]
+acquireResources :: forall m a. (Ord a, MonadIO m, MonadMask m, HasCallStack) => Int -> ResourcePool a -> Codensity m [a]
 acquireResources n pool = Codensity $ \f -> bracket acquire release (f . Set.toList)
   where
     release :: Set.Set a -> m ()