alex/reaper related

.github/workflows/ci.yaml

@@ -15,17 +15,15 @@ jobs:
         os: [ubuntu-latest] # [macOS-latest, windows-latest] do not come with docker :(
         cabal: ["3.6"]
         ghc:
-          - 8.8.4
-          - 8.10.7
-          - 9.0.2
-          - 9.2.4
-          - 9.4.2
+          - 9.2.8
+          - 9.4.8
+          - 9.6.4
 
     steps:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell/actions/setup@v2
+    - uses: haskell-actions/setup@v2.6.1
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
@@ -63,7 +61,7 @@ jobs:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell/actions/setup@v2
+    - uses: haskell-actions/setup@v2.6.1
       name: Setup Haskell Stack
       with:
         ghc-version: ${{ matrix.ghc }}

.github/workflows/lint.yaml

@@ -15,7 +15,7 @@ jobs:
 
     - name: Check code is formatted using Ormolu
       run: |
-        curl -L https://github.com/tweag/ormolu/releases/download/0.5.3.0/ormolu-Linux.zip -o ormolu.zip
+        curl -L https://github.com/tweag/ormolu/releases/download/0.7.2.0/ormolu-Linux.zip -o ormolu.zip
         unzip ormolu.zip
 
         git ls-files | grep \.hs | xargs ./ormolu --mode=inplace

.gitignore

@@ -1,3 +1,4 @@
+.DS_Store
 dist
 dist-*
 cabal-dev

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,14 @@ import qualified System.IO
 import qualified System.Process as Process
 import TestContainers.Trace (Trace (..), Tracer, withTrace)
 
+-- | Shared property between Docker resources.
+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,13 +22,19 @@ import qualified Network.Socket as Socket
 import qualified Network.Socket.ByteString as Socket
 import qualified System.Random as Random
 
--- | Reaper for safe resource cleanup.
+-- | 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
-  { -- | @runReaper label value@ reaps Docker any Docker resource with a matching
-    -- label.
-    runReaper :: Text -> Text -> IO (),
+  { -- | Registers a @label = value@ pair for reaping. Reaping happens when
+    -- closing/de-allocating of the 'Reaper' through 'MonadResource'.
+    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.
     labels :: [(Text, Text)]
@@ -88,23 +94,32 @@ newRyukReaper host port = do
               (Socket.addrSocketType address)
               (Socket.addrProtocol address)
           Socket.connect socket (Socket.addrAddress address)
-          pure (socket, runRyuk sessionId (Ryuk socket))
+
+          -- Construct the reaper and regiter the session with it.
+          -- Doing it here intead of in the teardown (like we did before)
+          -- guarantees the Reaper knows about our session.
+          let reaper =
+                newReaper sessionId (Ryuk socket)
+          register reaper sessionIdLabel sessionId
+
+          pure (socket, reaper)
       )
-      ( \(socket, ryuk) -> do
-          runReaper ryuk sessionIdLabel sessionId
+      ( \(socket, _ryuk) -> do
+          -- Tearing down the connection lets Ryuk know it can reap the
+          -- running containers.
           Socket.close socket
       )
 
   pure ryuk
 
-runRyuk ::
+newReaper ::
   -- | Session id
   Text ->
   Ryuk ->
   Reaper
-runRyuk sessionId ryuk =
+newReaper sessionId ryuk =
   Reaper
-    { runReaper = \label value -> do
+    { register = \label value -> do
         Socket.sendAll
           (ryukSocket ryuk)
           ("label=" <> encodeUtf8 label <> "=" <> encodeUtf8 value <> "\n")

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

testcontainers.cabal

@@ -48,7 +48,7 @@ library
     , aeson-optics   >=1.1     && <2
     , async
     , base           >=4.12    && <5
-    , bytestring     >=0.10.8  && <0.12
+    , bytestring     >=0.10.8  && <0.13
     , directory      >=1.3.6   && <2
     , exceptions     >=0.10.4  && <0.11
     , http-client    >=0.5.14  && <1
@@ -59,7 +59,7 @@ library
     , process        >=1.6.5   && <1.7
     , random         >=1.2     && <2
     , resourcet      >=1.2.4   && <1.4
-    , tasty          >=1.0     && <1.5
+    , tasty          >=1.0     && <1.6
     , text           >=1.2.3   && <3
     , unliftio-core  >=0.1.0   && <0.3