Introduce concurrent run strategy for launching containers

src/TestContainers.hs

@@ -32,6 +32,7 @@ module TestContainers
     M.setExpose,
     M.setWaitingFor,
     M.withFollowLogs,
+    M.withDependencies,
 
     -- * Logs
     M.LogConsumer,

src/TestContainers/Config.hs

@@ -1,13 +1,14 @@
 module TestContainers.Config
-  ( Config (..),
+  ( RunStrategy (..),
+    Config (..),
     defaultConfig,
     defaultDockerConfig,
     determineConfig,
   )
 where
 
 import {-# SOURCE #-} TestContainers.Docker (createRyukReaper)
-import TestContainers.Monad (Config (..))
+import TestContainers.Monad (Config (..), RunStrategy (..))
 
 -- | Default configuration.
 --
@@ -17,7 +18,8 @@ defaultConfig =
   Config
     { configDefaultWaitTimeout = Just 60,
       configTracer = mempty,
-      configCreateReaper = createRyukReaper
+      configCreateReaper = createRyukReaper,
+      configRunStrategy = SequentialRunStrategy
     }
 
 -- | Default configuration.

src/TestContainers/Docker.hs

@@ -91,6 +91,7 @@ module TestContainers.Docker
     setLink,
     setExpose,
     setWaitingFor,
+    withDependencies,
     run,
 
     -- * Following logs
@@ -155,7 +156,8 @@ module TestContainers.Docker
 where
 
 import Control.Concurrent (threadDelay)
-import Control.Exception (IOException, throw)
+import qualified Control.Concurrent.Async
+import Control.Exception (IOException, evaluate, throw)
 import Control.Monad (forM_, replicateM, unless)
 import Control.Monad.Catch
   ( Exception,
@@ -166,11 +168,12 @@ import Control.Monad.Catch
     try,
   )
 import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO))
+import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO), askRunInIO)
 import Control.Monad.Reader (MonadReader (..))
 import Control.Monad.Trans.Resource
   ( ReleaseKey,
     ResIO,
+    allocate,
     register,
     runResourceT,
   )
@@ -206,12 +209,13 @@ import Optics.Optic ((%), (<&>))
 import System.Directory (doesFileExist)
 import System.Environment (lookupEnv)
 import System.IO (Handle, hClose)
-import System.IO.Unsafe (unsafePerformIO)
+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
 import qualified System.Process as Process
 import qualified System.Random as Random
 import System.Timeout (timeout)
 import TestContainers.Config
   ( Config (..),
+    RunStrategy (..),
     defaultDockerConfig,
     determineConfig,
   )
@@ -283,7 +287,8 @@ data ContainerRequest = ContainerRequest
     labels :: [(Text, Text)],
     noReaper :: Bool,
     followLogs :: Maybe LogConsumer,
-    workDirectory :: Maybe Text
+    workDirectory :: Maybe Text,
+    dependencies :: [Container]
   }
 
 instance WithoutReaper ContainerRequest where
@@ -317,7 +322,8 @@ containerRequest image =
       labels = mempty,
       noReaper = False,
       followLogs = Nothing,
-      workDirectory = Nothing
+      workDirectory = Nothing,
+      dependencies = []
     }
 
 -- | Set the name of a Docker container. This is equivalent to invoking @docker run@
@@ -430,6 +436,13 @@ withFollowLogs :: LogConsumer -> ContainerRequest -> ContainerRequest
 withFollowLogs logConsumer request =
   request {followLogs = Just logConsumer}
 
+-- |
+--
+-- @since x.x.x
+withDependencies :: [Container] -> ContainerRequest -> ContainerRequest
+withDependencies dependencies request =
+  request {dependencies}
+
 -- | Defintion of a 'Port'. Allows for specifying ports using various protocols. Due to the
 -- 'Num' and 'IsString' instance allows for convenient Haskell literals.
 --
@@ -531,7 +544,8 @@ run request = do
           labels,
           noReaper,
           followLogs,
-          workDirectory
+          workDirectory,
+          dependencies
         } = request
 
   config@Config {configTracer, configCreateReaper} <-
@@ -572,38 +586,69 @@ run request = do
             ++ [[tag]]
             ++ [command | Just command <- [cmd]]
 
-  stdout <- docker configTracer dockerRun
+  actuallyRunDocker <- applyRunStrategy $ do
+    _ <-
+      liftIO $
+        traverse evaluate dependencies
 
-  let id :: ContainerId
-      !id =
-        -- N.B. Force to not leak STDOUT String
-        strip (pack stdout)
+    stdout <- docker configTracer dockerRun
 
-      -- Careful, this is really meant to be lazy
-      ~inspectOutput =
-        unsafePerformIO $
-          internalInspect configTracer id
+    let id :: ContainerId
+        !id =
+          -- N.B. Force to not leak STDOUT String
+          strip (pack stdout)
 
-  -- We don't issue 'ReleaseKeys' for cleanup anymore. Ryuk takes care of cleanup
-  -- for us once the session has been closed.
-  releaseKey <- register (pure ())
+        -- Careful, this is really meant to be lazy
+        ~inspectOutput =
+          unsafePerformIO $
+            internalInspect configTracer id
 
-  forM_ followLogs $
-    dockerFollowLogs configTracer id
+    -- We don't issue 'ReleaseKeys' for cleanup anymore. Ryuk takes care of cleanup
+    -- for us once the session has been closed.
+    releaseKey <- register (pure ())
 
-  let container =
-        Container
-          { id,
-            releaseKey,
-            image,
-            inspectOutput,
-            config
-          }
+    forM_ followLogs $
+      dockerFollowLogs configTracer id
 
-  -- Last but not least, execute the WaitUntilReady checks
-  waitUntilReady container readiness
+    let container =
+          Container
+            { id,
+              releaseKey,
+              image,
+              inspectOutput,
+              config
+            }
 
-  pure container
+    -- Last but not least, execute the WaitUntilReady checks
+    waitUntilReady container readiness
+
+    pure container
+
+  actuallyRunDocker
+
+applyRunStrategy ::
+  TestContainer a ->
+  TestContainer (TestContainer a)
+applyRunStrategy action = do
+  Config {configRunStrategy} <-
+    ask
+  case configRunStrategy of
+    SequentialRunStrategy ->
+      pure action
+    ConcurrentRunStrategy _limit -> do
+      runInIO <-
+        askRunInIO
+
+      (_releaseKey, handle) <-
+        allocate
+          (Control.Concurrent.Async.async (runInIO action))
+          Control.Concurrent.Async.cancel
+
+      let returnAction =
+            liftIO $ unsafeInterleaveIO $ do
+              Control.Concurrent.Async.wait handle
+
+      pure returnAction
 
 -- | Sets up a Ryuk 'Reaper'.
 --

src/TestContainers/Monad.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -14,33 +15,52 @@ module TestContainers.Monad
     runTestContainer,
 
     -- * Runtime configuration
+    RunStrategy (..),
     Config (..),
   )
 where
 
 import Control.Applicative (liftA2)
+import qualified Control.Concurrent.Async
+import Control.Exception (evaluate)
 import Control.Monad.Catch
   ( MonadCatch,
     MonadMask,
     MonadThrow,
   )
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.IO.Unlift (MonadUnliftIO (..))
+import Control.Monad.IO.Unlift (MonadUnliftIO (..), askRunInIO)
 import Control.Monad.Reader (MonadReader (..), ReaderT, runReaderT)
-import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)
+import qualified Control.Monad.Trans.Resource
 import Data.IORef (newIORef, readIORef, writeIORef)
+import qualified System.IO.Unsafe
 import TestContainers.Docker.Reaper (Reaper)
 import TestContainers.Trace (Tracer)
 
+data RunStrategy
+  = -- | Run containers sequentially. This is the default behaviour of the runtime.
+    --
+    -- @since x.x.x
+    SequentialRunStrategy
+  | -- | Run and resolve graph of containers concurrently. This requires explicit
+    -- dependency annotations across the container graph.
+    --
+    -- An optional limit on concurrent @docker run@ invocations can be provided.
+    --
+    -- @since x.x.x
+    ConcurrentRunStrategy (Maybe Int)
+
 newtype TestContainerEnv = TestContainerEnv
   { config :: Config
   }
 
 -- | The heart and soul of the testcontainers library.
 --
 -- @since 0.5.0.0
-newtype TestContainer a = TestContainer {unTestContainer :: ReaderT TestContainerEnv (ResourceT IO) a}
+newtype TestContainer a = TestContainer
+  { unTestContainer :: ReaderT TestContainerEnv (Control.Monad.Trans.Resource.ResourceT IO) a
+  }
   deriving newtype
     ( Functor,
       Applicative,
@@ -49,7 +69,7 @@ newtype TestContainer a = TestContainer {unTestContainer :: ReaderT TestContaine
       MonadMask,
       MonadCatch,
       MonadThrow,
-      MonadResource,
+      Control.Monad.Trans.Resource.MonadResource,
       MonadFix
     )
 
@@ -94,7 +114,7 @@ runTestContainer config action = do
             liftIO (writeIORef reaperRef (Just reaper))
             pure reaper
 
-  runResourceT
+  Control.Monad.Trans.Resource.runResourceT
     ( runReaderT
         (unTestContainer action)
         ( TestContainerEnv
@@ -125,5 +145,9 @@ data Config = Config
     -- | Traces execution inside testcontainers library.
     configTracer :: Tracer,
     -- | How to obtain a 'Reaper'
-    configCreateReaper :: TestContainer Reaper
+    configCreateReaper :: TestContainer Reaper,
+    -- |
+    --
+    -- @since x.x.x
+    configRunStrategy :: RunStrategy
   }