diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for testcontainer-hs +## 0.5.1.0 -- 2025-01-14 + +* Introduce `withWorkingDirectory` to set the working directory inside a container (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/37) + +* Add `fromExistingNetwork` to allow connecting containers to existing, unmanaged networks (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/41) + +* Add `setMemory` to limit the memory of a Docker container; + +* Add `setCpus` to limit the CPUs limit of a docker container; + +* Add `fromImageId` to get an `Image` from an image id; + ## 0.5.0.0 -- 2023-02-20 * BREAKING: Refined lifecycle management. testcontainers is now using testcontainers/ryuk resource reaper to cleanup containers, networks and volumes. Release keys for containers are deprecated. (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/33) diff --git a/src/TestContainers.hs b/src/TestContainers.hs --- a/src/TestContainers.hs +++ b/src/TestContainers.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} + -- | -- This module shall be used as entrypoint to the testcontainers library. It exports -- all the necessary types and functions for most common use-cases. @@ -10,12 +12,14 @@ -- * Referring to Docker images M.ToImage, M.fromTag, + M.fromImageId, M.fromBuildContext, M.build, -- * @docker run@ parameters M.ContainerRequest, M.containerRequest, + M.withoutReaper, M.setName, M.setFixedName, M.setSuffixedName, @@ -24,6 +28,9 @@ M.setVolumeMounts, M.setRm, M.setEnv, + M.setMemory, + M.setCpus, + M.withWorkingDirectory, M.withNetwork, M.withNetworkAlias, M.setLink, @@ -45,6 +52,7 @@ M.Network, M.NetworkId, M.createNetwork, + M.fromExistingNetwork, -- * Port M.Port (..), diff --git a/src/TestContainers/Docker.hs b/src/TestContainers/Docker.hs --- a/src/TestContainers/Docker.hs +++ b/src/TestContainers/Docker.hs @@ -65,6 +65,7 @@ -- * Referring to images ToImage, fromTag, + fromImageId, fromBuildContext, fromDockerfile, build, @@ -75,15 +76,19 @@ -- * Running containers ContainerRequest, containerRequest, + withoutReaper, withLabels, setName, setFixedName, setSuffixedName, setRandomName, setCmd, + setMemory, + setCpus, setVolumeMounts, setRm, setEnv, + withWorkingDirectory, withNetwork, withNetworkAlias, setLink, @@ -103,6 +108,7 @@ networkId, networkRequest, createNetwork, + fromExistingNetwork, withIpv6, withDriver, @@ -175,7 +181,8 @@ import qualified Data.Aeson.Optics as Optics import qualified Data.ByteString.Lazy.Char8 as LazyByteString import Data.Function ((&)) -import Data.List (find) +import Data.List (find, stripPrefix) +import Data.Maybe (fromMaybe) import Data.String (IsString (..)) import Data.Text (Text, pack, splitOn, strip, unpack) import Data.Text.Encoding (encodeUtf8) @@ -198,8 +205,9 @@ import qualified Network.Socket as Socket import Optics.Fold (pre) import Optics.Operators ((^?)) -import Optics.Optic ((%)) +import Optics.Optic ((%), (<&>)) import System.Directory (doesFileExist) +import System.Environment (lookupEnv) import System.IO (Handle, hClose) import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process @@ -216,6 +224,7 @@ InspectOutput, LogConsumer, Pipe (..), + WithoutReaper (..), consoleLogConsumer, docker, dockerFollowLogs, @@ -226,6 +235,7 @@ NetworkId, NetworkRequest, createNetwork, + fromExistingNetwork, networkId, networkRequest, withDriver, @@ -269,15 +279,21 @@ volumeMounts :: [(Text, Text)], network :: Maybe (Either Network Text), networkAlias :: Maybe Text, + cpus :: Maybe Text, + memory :: Maybe Text, links :: [ContainerId], naming :: NamingStrategy, rmOnExit :: Bool, readiness :: WaitUntilReady, labels :: [(Text, Text)], noReaper :: Bool, - followLogs :: Maybe LogConsumer + followLogs :: Maybe LogConsumer, + workDirectory :: Maybe Text } +instance WithoutReaper ContainerRequest where + withoutReaper request = request {noReaper = True} + -- | Parameters for a naming a Docker container. -- -- @since 0.5.0.0 @@ -300,12 +316,15 @@ volumeMounts = [], network = Nothing, networkAlias = Nothing, + memory = Nothing, + cpus = Nothing, links = [], rmOnExit = False, readiness = mempty, labels = mempty, noReaper = False, - followLogs = Nothing + followLogs = Nothing, + workDirectory = Nothing } -- | Set the name of a Docker container. This is equivalent to invoking @docker run@ @@ -351,6 +370,22 @@ setCmd newCmd req = req {cmd = Just newCmd} +-- | Set the memory limit of a Docker container. This is equivalent to +-- invoking @docker run@ with the @--memory@ parameter. +-- +-- @since 0.5.1.0 +setMemory :: Text -> ContainerRequest -> ContainerRequest +setMemory newMemory req = + req {memory = Just newMemory} + +-- | Set the cpus limit of a Docker container. This is equivalent to +-- invoking @docker run@ with the @--cpus@ parameter. +-- +-- @since 0.5.1.0 +setCpus :: Text -> ContainerRequest -> ContainerRequest +setCpus newCpus req = + req {cpus = Just newCpus} + -- | The volume mounts to link to Docker container. This is the equivalent -- of passing the command on the @docker run -v@ invocation. setVolumeMounts :: [(Text, Text)] -> ContainerRequest -> ContainerRequest @@ -373,6 +408,13 @@ setEnv newEnv req = req {env = newEnv} +-- | Sets the working directory inside the container. +-- +-- @since 0.5.1.0 +withWorkingDirectory :: Text -> ContainerRequest -> ContainerRequest +withWorkingDirectory workdir request = + request {workDirectory = Just workdir} + -- | Set the network the container will connect to. This is equivalent to passing -- @--network network_name@ to @docker run@. -- @@ -506,12 +548,15 @@ volumeMounts, network, networkAlias, + memory, + cpus, links, rmOnExit, readiness, labels, noReaper, - followLogs + followLogs, + workDirectory } = request config@Config {configTracer, configCreateReaper} <- @@ -548,6 +593,9 @@ ++ [["--link", container] | container <- links] ++ [["--volume", src <> ":" <> dest] | (src, dest) <- volumeMounts] ++ [["--rm"] | rmOnExit] + ++ [["--workdir", workdir] | Just workdir <- [workDirectory]] + ++ [["--memory", value] | Just value <- [memory]] + ++ [["--cpus", value] | Just value <- [cpus]] ++ [[tag]] ++ [command | Just command <- [cmd]] @@ -589,11 +637,19 @@ -- @since 0.5.0.0 createRyukReaper :: TestContainer Reaper createRyukReaper = do + dockerSocketLocation <- + liftIO $ + lookupEnv "DOCKER_HOST" + <&> (>>= stripPrefix "unix://") + <&> fromMaybe "/var/run/docker.sock" ryukContainer <- run $ containerRequest (fromTag ryukImageTag) - & skipReaper - & setVolumeMounts [("/var/run/docker.sock", "/var/run/docker.sock")] + & + -- Ryuk destroys itself once it reaped the resources, + -- no need to register itself with itself. + withoutReaper + & setVolumeMounts [(pack dockerSocketLocation, "/var/run/docker.sock")] & setExpose [ryukPort] & setWaitingFor (waitUntilMappedPortReachable ryukPort) & setRm True @@ -603,14 +659,6 @@ newRyukReaper ryukContainerAddress ryukContainerPort --- | Internal attribute, serving as a loop breaker: When runnign a container --- we ensure a 'Reaper' is present, since the 'Reaper' itself is a running --- container we need to break the loop to avoid spinning up a new 'Reaper' for --- the 'Reaper'. -skipReaper :: ContainerRequest -> ContainerRequest -skipReaper request = - request {noReaper = True} - -- | Kills a Docker container. `kill` is essentially @docker kill@. -- -- @since 0.1.0.0 @@ -699,7 +747,7 @@ { runToImage = action } --- | Get an `Image` from a tag. +-- | Get an `Image` from a tag. This runs @docker pull --quiet @ to obtain an image id. -- -- @since 0.1.0.0 fromTag :: ImageTag -> ToImage @@ -711,6 +759,15 @@ { tag = strip (pack output) } +-- | Get an `Image` from an image id. This doesn't run @docker pull@ or any other Docker command +-- on construction. +-- +-- @since 0.5.1.0 +fromImageId :: Text -> ToImage +fromImageId imageId = + defaultToImage $ + pure Image {tag = imageId} + -- | Build the image from a build path and an optional path to the -- Dockerfile (default is Dockerfile) -- @@ -890,7 +947,8 @@ withTrace configTracer (TraceHttpCall endpointHost endpointPort (Right code)) - unless (code `elem` acceptableStatusCodes) $ + unless (code `elem` acceptableStatusCodes) $ do + liftIO (threadDelay 500000) retry manager Left (exception :: HttpException) -> do withTrace @@ -1087,8 +1145,8 @@ 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 -> diff --git a/src/TestContainers/Docker/Internal.hs b/src/TestContainers/Docker/Internal.hs --- a/src/TestContainers/Docker/Internal.hs +++ b/src/TestContainers/Docker/Internal.hs @@ -21,6 +21,9 @@ LogConsumer, consoleLogConsumer, dockerFollowLogs, + + -- * Common abstractions for Docker resources + WithoutReaper (..), ) where @@ -39,6 +42,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 0.5.1.0 + withoutReaper :: request -> request -- | Identifies a network within the Docker runtime. Assigned by @docker network create@ -- diff --git a/src/TestContainers/Docker/Network.hs b/src/TestContainers/Docker/Network.hs --- a/src/TestContainers/Docker/Network.hs +++ b/src/TestContainers/Docker/Network.hs @@ -10,11 +10,13 @@ networkId, -- * Creating networks + fromExistingNetwork, createNetwork, NetworkRequest, networkRequest, withDriver, withIpv6, + withoutReaper, ) where @@ -22,7 +24,7 @@ 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) @@ -46,9 +48,13 @@ 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 @@ -57,7 +63,8 @@ NetworkRequest { ipv6 = False, driver = Nothing, - labels = [] + labels = [], + noReaper = False } -- | Enable IPv6 for the Docker network. @@ -74,6 +81,15 @@ withDriver driver request = request {driver = Just driver} +-- | Creates a 'Network' from an existing 'NetworkId'. Note that the 'Network' is +-- not managed by the 'TestContainer' monad and as such is not being cleaned up +-- afterwards. +-- +-- @since 0.5.1.0 +fromExistingNetwork :: NetworkId -> TestContainer Network +fromExistingNetwork id = + pure Network {id} + -- | Creates a new 'Network' from a 'NetworkRequest'. -- -- @since 0.5.0.0 @@ -90,7 +106,7 @@ -- 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 $ diff --git a/src/TestContainers/Docker/Reaper.hs b/src/TestContainers/Docker/Reaper.hs --- a/src/TestContainers/Docker/Reaper.hs +++ b/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.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)] @@ -83,25 +89,37 @@ address <- head <$> Socket.getAddrInfo (Just hints) (Just (unpack host)) (Just (show port)) socket <- - Socket.openSocket address + Socket.socket + (Socket.addrFamily address) + (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") diff --git a/src/TestContainers/Docker/State.hs b/src/TestContainers/Docker/State.hs --- a/src/TestContainers/Docker/State.hs +++ b/src/TestContainers/Docker/State.hs @@ -68,7 +68,7 @@ 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 value) = case value ^? Optics.key "OOMKilled" - % Optics._Bool of + % Optics._Bool of Just True -> True _ -> False @@ -97,7 +97,7 @@ 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 value) = case value ^? Optics.key "ExitCode" - % Optics._Integer of + % Optics._Integer of Just exitCode -> Just (fromIntegral exitCode) _ -> Nothing @@ -119,7 +119,7 @@ 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 value) = case value ^? Optics.key "StartedAt" - % Optics._String of + % Optics._String of Just err -> Just err _ -> Nothing @@ -141,6 +141,6 @@ stateFinishedAt (State value) = case value ^? Optics.key "FinishedAt" - % Optics._String of + % Optics._String of Just err -> Just err _ -> Nothing diff --git a/src/TestContainers/Hspec.hs b/src/TestContainers/Hspec.hs --- a/src/TestContainers/Hspec.hs +++ b/src/TestContainers/Hspec.hs @@ -30,18 +30,25 @@ -- initialization and de-initialization of the containers. -- -- @ +-- data ContainerPorts = ContainerPorts { +-- redisPort :: Int, +-- kafkaPort :: Int +-- } -- --- containers :: MonadDocker m => m Boolean +-- containers :: MonadDocker m => m ContainerPorts -- containers = do --- _redis <- TestContainers.run $ TestContainers.containerRequest TestContainers.redis --- _kafka <- TestContainers.run $ TestContainers.containerRequest TestContainers.kafka --- pure True +-- redis <- TestContainers.run $ TestContainers.containerRequest TestContainers.redis +-- kafka <- TestContainers.run $ TestContainers.containerRequest TestContainers.kafka +-- pure ContainerPorts { +-- redisPort = TestContainers.containerPort redis "6379/tcp", +-- kafkaPort = TestContainers.containerPort kafka "9092/tcp" +-- } -- -- example :: Spec -- example = -- around (withContainers containers) $ describe "Example tests" --- it "first test" $ \\isBoolean -> do --- isBoolean `shouldBe` True +-- it "some test that uses redis and kafka" $ \ContainerPorts{redisPort, kafkaPort} -> do +-- redisPort `shouldNotBe` kafkaPort -- @ -- -- `withContainers` allows you naturally scope the handling of containers for your tests. diff --git a/src/TestContainers/Image.hs b/src/TestContainers/Image.hs --- a/src/TestContainers/Image.hs +++ b/src/TestContainers/Image.hs @@ -16,6 +16,7 @@ build, fromBuildContext, fromDockerfile, + fromImageId, fromTag, ) diff --git a/test/TestContainers/HspecSpec.hs b/test/TestContainers/HspecSpec.hs --- a/test/TestContainers/HspecSpec.hs +++ b/test/TestContainers/HspecSpec.hs @@ -1,21 +1,30 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module TestContainers.HspecSpec (main, spec_all) where import Test.Hspec import TestContainers.Hspec ( TestContainer, + containerPort, containerRequest, redis, run, withContainers, ) -containers1 :: - TestContainer () +data ContainerPorts = ContainerPorts + { redisPort :: Int + } + +containers1 :: TestContainer ContainerPorts containers1 = do - _ <- run $ containerRequest redis - pure () + redisContainer <- run $ containerRequest redis + pure + ContainerPorts + { redisPort = containerPort redisContainer "6379/tcp" + } main :: IO () main = hspec spec_all @@ -24,5 +33,5 @@ spec_all = around (withContainers containers1) $ describe "TestContainers tests" $ - it "test1" $ - shouldBe () + it "test1" $ \ContainerPorts {} -> + shouldBe () () diff --git a/testcontainers.cabal b/testcontainers.cabal --- a/testcontainers.cabal +++ b/testcontainers.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: testcontainers -version: 0.5.0.0 +version: 0.5.1.0 synopsis: Docker containers for your integration tests. description: testcontainers is a Haskell library that provides a friendly API to @@ -20,7 +20,7 @@ README.md tested-with: - GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 || ==9.8.2 source-repository head type: git @@ -48,7 +48,7 @@ , 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 @@ , 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 @@ -84,7 +84,7 @@ base , hspec >=2.0 && <3.0 , tasty - , tasty-discover >=4.2.1 && <4.3 + , tasty-discover >=4.2.1 && <6 , tasty-hspec , tasty-hunit , testcontainers