Introduce withoutReaper for containers and networks

src/TestContainers.hs

@@ -16,6 +16,7 @@ module TestContainers
     -- * @docker run@ parameters
     M.ContainerRequest,
     M.containerRequest,
+    M.withoutReaper,
     M.setName,
     M.setFixedName,
     M.setSuffixedName,

src/TestContainers/Docker.hs

@@ -75,6 +75,7 @@ module TestContainers.Docker
     -- * Running containers
     ContainerRequest,
     containerRequest,
+    withoutReaper,
     withLabels,
     setName,
     setFixedName,
@@ -220,6 +221,7 @@ import TestContainers.Docker.Internal
     InspectOutput,
     LogConsumer,
     Pipe (..),
+    WithoutReaper (..),
     consoleLogConsumer,
     docker,
     dockerFollowLogs,
@@ -284,6 +286,9 @@ data ContainerRequest = ContainerRequest
     workDirectory :: Maybe Text
   }
 
+instance WithoutReaper ContainerRequest where
+  withoutReaper request = request {noReaper = True}
+
 -- | Parameters for a naming a Docker container.
 --
 -- @since 0.5.0.0
@@ -1109,8 +1114,8 @@ internalContainerIp :: Container -> Text
 internalContainerIp Container {id, inspectOutput} =
   case inspectOutput
     ^? Optics.key "NetworkSettings"
-    % Optics.key "IPAddress"
-    % Optics._String of
+      % Optics.key "IPAddress"
+      % Optics._String of
     Nothing ->
       throw $ InspectOutputUnexpected {id}
     Just address ->

src/TestContainers/Docker/Internal.hs

@@ -21,6 +21,9 @@ module TestContainers.Docker.Internal
     LogConsumer,
     consoleLogConsumer,
     dockerFollowLogs,
+
+    -- * Common abstractions for Docker resources
+    WithoutReaper (..),
   )
 where
 
@@ -40,6 +43,13 @@ import qualified System.IO
 import qualified System.Process as Process
 import TestContainers.Trace (Trace (..), Tracer, withTrace)
 
+class WithoutReaper request where
+  -- | Do not register the docker resource (container, register, etc.) with the resource reaper.
+  -- Careful, doing this will make your container leak on shutdown if not explicitly stopped.
+  --
+  -- @since x.x.x
+  withoutReaper :: request -> request
+
 -- | Identifies a network within the Docker runtime. Assigned by @docker network create@
 --
 -- @since 0.5.0.0

src/TestContainers/Docker/Network.hs

@@ -16,14 +16,15 @@ module TestContainers.Docker.Network
     networkRequest,
     withDriver,
     withIpv6,
+    withoutReaper,
   )
 where
 
 import Control.Monad (replicateM)
 import Control.Monad.Reader (ask)
 import Data.Text (Text, pack, strip)
 import qualified System.Random as Random
-import TestContainers.Docker.Internal (NetworkId, docker)
+import TestContainers.Docker.Internal (NetworkId, WithoutReaper (..), docker)
 import TestContainers.Docker.Reaper (reaperLabels)
 import TestContainers.Monad (Config (..), TestContainer)
 import Prelude hiding (id)
@@ -47,9 +48,13 @@ networkId Network {id} = id
 data NetworkRequest = NetworkRequest
   { ipv6 :: Bool,
     driver :: Maybe Text,
-    labels :: [(Text, Text)]
+    labels :: [(Text, Text)],
+    noReaper :: Bool
   }
 
+instance WithoutReaper NetworkRequest where
+  withoutReaper request = request {noReaper = True}
+
 -- | Default parameters for creating a new Docker network.
 --
 -- @since 0.5.0.0
@@ -58,7 +63,8 @@ networkRequest =
   NetworkRequest
     { ipv6 = False,
       driver = Nothing,
-      labels = []
+      labels = [],
+      noReaper = False
     }
 
 -- | Enable IPv6 for the Docker network.
@@ -100,7 +106,7 @@ createNetwork NetworkRequest {..} = do
   -- Creating the network with the reaper labels ensures cleanup
   -- at the end of the session
   let additionalLabels =
-        reaperLabels reaper
+        if noReaper then [] else reaperLabels reaper
 
   stdout <-
     docker configTracer $

src/TestContainers/Docker/Reaper.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module TestContainers.Docker.Reaper
-  ( Reaper(..),
+  ( Reaper (..),
     reaperLabels,
 
     -- * Ryuk based reaper
@@ -22,18 +22,18 @@ import qualified Network.Socket as Socket
 import qualified Network.Socket.ByteString as Socket
 import qualified System.Random as Random
 
--- | Reaper for safe resource cleanup. This type is exposed to allow users to 
+-- | Reaper for safe resource cleanup. This type is exposed to allow users to
 -- create their own 'Reapers'.
 --
 -- @since 0.5.0.0
 data Reaper = Reaper
-  { -- | Registers a @label = value@ pair for reaping. Reaping happens when 
+  { -- | Registers a @label = value@ pair for reaping. Reaping happens when
     -- closing/de-allocating of the 'Reaper' through 'MonadResource'.
-    register :: 
-      -- | Label
-      Text -> 
-      -- | Value
-      Text -> 
+    register ::
+      -- \| Label
+      Text ->
+      -- \| Value
+      Text ->
       IO (),
     -- | Additional labels to add to any Docker resource on creation. Adding the
     -- labels is necessary in order for the 'Reaper' to find resources for cleanup.

src/TestContainers/Docker/State.hs

@@ -68,7 +68,7 @@ stateStatus :: State -> Status
 stateStatus (State value) =
   case value
     ^? Optics.key "Status"
-    % Optics._String of
+      % Optics._String of
     Just "created" -> Created
     Just "running" -> Running
     Just "paused" -> Paused
@@ -86,7 +86,7 @@ stateOOMKilled :: State -> Bool
 stateOOMKilled (State value) =
   case value
     ^? Optics.key "OOMKilled"
-    % Optics._Bool of
+      % Optics._Bool of
     Just True -> True
     _ -> False
 
@@ -97,7 +97,7 @@ statePid :: State -> Maybe Int
 statePid (State value) =
   case value
     ^? Optics.key "Pid"
-    % Optics._Integer of
+      % Optics._Integer of
     Just pid -> Just (fromIntegral pid)
     _ -> Nothing
 
@@ -108,7 +108,7 @@ stateExitCode :: State -> Maybe Int
 stateExitCode (State value) =
   case value
     ^? Optics.key "ExitCode"
-    % Optics._Integer of
+      % Optics._Integer of
     Just exitCode -> Just (fromIntegral exitCode)
     _ -> Nothing
 
@@ -119,7 +119,7 @@ stateError :: State -> Maybe Text
 stateError (State value) =
   case value
     ^? Optics.key "Error"
-    % Optics._String of
+      % Optics._String of
     Just err -> Just err
     _ -> Nothing
 
@@ -130,7 +130,7 @@ stateStartedAt :: State -> Maybe Text
 stateStartedAt (State value) =
   case value
     ^? Optics.key "StartedAt"
-    % Optics._String of
+      % Optics._String of
     Just err -> Just err
     _ -> Nothing
 
@@ -141,6 +141,6 @@ stateFinishedAt :: State -> Maybe Text
 stateFinishedAt (State value) =
   case value
     ^? Optics.key "FinishedAt"
-    % Optics._String of
+      % Optics._String of
     Just err -> Just err
     _ -> Nothing