diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for testcontainer-hs +## 0.5.2.0 -- 2025-08-28 + +* Introduce `withCopyFileToContainer` to copy local files to the container (@LaurentRDC, https://github.com/testcontainers/testcontainers-hs/pull/62) + ## 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) diff --git a/src/TestContainers.hs b/src/TestContainers.hs --- a/src/TestContainers.hs +++ b/src/TestContainers.hs @@ -31,6 +31,7 @@ M.setMemory, M.setCpus, M.withWorkingDirectory, + M.withCopyFileToContainer, M.withNetwork, M.withNetworkAlias, M.setLink, @@ -41,6 +42,7 @@ -- * Logs M.LogConsumer, M.consoleLogConsumer, + M.prefixedLogConsumer, -- * @docker network@ parameters M.NetworkRequest, diff --git a/src/TestContainers/Docker.hs b/src/TestContainers/Docker.hs --- a/src/TestContainers/Docker.hs +++ b/src/TestContainers/Docker.hs @@ -89,6 +89,7 @@ setRm, setEnv, withWorkingDirectory, + withCopyFileToContainer, withNetwork, withNetworkAlias, setLink, @@ -99,6 +100,7 @@ -- * Following logs LogConsumer, consoleLogConsumer, + prefixedLogConsumer, withFollowLogs, -- * Network related functionality @@ -159,7 +161,7 @@ import Control.Concurrent (threadDelay) import Control.Exception (IOException, throw) -import Control.Monad (forM_, replicateM, unless) +import Control.Monad (forM_, replicateM, unless, void) import Control.Monad.Catch ( Exception, MonadCatch, @@ -229,6 +231,7 @@ docker, dockerFollowLogs, dockerWithStdin, + prefixedLogConsumer, ) import TestContainers.Docker.Network ( Network, @@ -288,7 +291,8 @@ labels :: [(Text, Text)], noReaper :: Bool, followLogs :: Maybe LogConsumer, - workDirectory :: Maybe Text + workDirectory :: Maybe Text, + copyFilesToContainer :: [(FilePath, FilePath)] } instance WithoutReaper ContainerRequest where @@ -324,7 +328,8 @@ labels = mempty, noReaper = False, followLogs = Nothing, - workDirectory = Nothing + workDirectory = Nothing, + copyFilesToContainer = mempty } -- | Set the name of a Docker container. This is equivalent to invoking @docker run@ @@ -415,6 +420,27 @@ withWorkingDirectory workdir request = request {workDirectory = Just workdir} +-- | Copies a file from the host to the container. Call this function +-- multiple times to copy multiple files to the container. +-- +-- This can be used, for example, to initialize a database: +-- +-- >>> :{ +-- containerRequest (fromTag "postgres:16-alpine") +-- & withCopyFileToContainer "my-init-script.sql" "/docker-entrypoint-initdb.d/" +-- :} +-- +-- @since 0.5.2.0 +withCopyFileToContainer :: + -- | File on the host + FilePath -> + -- | Directory in the container + FilePath -> + ContainerRequest -> + ContainerRequest +withCopyFileToContainer fileFromHost containerDirectory request = + request {copyFilesToContainer = copyFilesToContainer request <> [(fileFromHost, containerDirectory)]} + -- | Set the network the container will connect to. This is equivalent to passing -- @--network network_name@ to @docker run@. -- @@ -556,7 +582,8 @@ labels, noReaper, followLogs, - workDirectory + workDirectory, + copyFilesToContainer } = request config@Config {configTracer, configCreateReaper} <- @@ -578,35 +605,43 @@ Just . (prefix <>) . ("-" <>) . pack <$> replicateM 6 (Random.randomRIO ('a', 'z')) - let dockerRun :: [Text] - dockerRun = + -- Instead of using `docker run`, we use the more manual `docker create` + `docker start`. + -- This allows to get the container ID early from `docker create`, and thus + -- optionally copy files using `docker cp`. + let dockerCreate :: [Text] + dockerCreate = concat $ - [["run"]] - ++ [["--detach"]] - ++ [["--name", containerName] | Just containerName <- [name]] - ++ [["--label", label <> "=" <> value] | (label, value) <- additionalLabels ++ labels] + [["create"]] + ++ [["--cpus", value] | Just value <- [cpus]] ++ [["--env", variable <> "=" <> value] | (variable, value) <- env] - ++ [["--publish", pack (show port) <> "/" <> protocol] | Port {port, protocol} <- exposedPorts] + ++ [["--label", label <> "=" <> value] | (label, value) <- additionalLabels ++ labels] + ++ [["--link", container] | container <- links] + ++ [["--memory", value] | Just value <- [memory]] + ++ [["--name", containerName] | Just containerName <- [name]] ++ [["--network", networkName] | Just (Right networkName) <- [network]] ++ [["--network", networkId dockerNetwork] | Just (Left dockerNetwork) <- [network]] ++ [["--network-alias", alias] | Just alias <- [networkAlias]] - ++ [["--link", container] | container <- links] - ++ [["--volume", src <> ":" <> dest] | (src, dest) <- volumeMounts] + ++ [["--publish", pack (show port) <> "/" <> protocol] | Port {port, protocol} <- exposedPorts] ++ [["--rm"] | rmOnExit] + ++ [["--volume", src <> ":" <> dest] | (src, dest) <- volumeMounts] ++ [["--workdir", workdir] | Just workdir <- [workDirectory]] - ++ [["--memory", value] | Just value <- [memory]] - ++ [["--cpus", value] | Just value <- [cpus]] ++ [[tag]] - ++ [command | Just command <- [cmd]] - stdout <- docker configTracer dockerRun + (id :: ContainerId) <- strip . pack <$> docker configTracer dockerCreate - let id :: ContainerId - !id = - -- N.B. Force to not leak STDOUT String - strip (pack stdout) + forM_ copyFilesToContainer $ \(hostFile, containerFile) -> + docker configTracer ["cp", pack hostFile, id <> ":" <> pack containerFile] - -- Careful, this is really meant to be lazy + let dockerStart :: [Text] + dockerStart = + concat $ + [["start"]] + ++ [[id]] + ++ [command | Just command <- [cmd]] + + void $ docker configTracer dockerStart + + let -- Careful, this is really meant to be lazy ~inspectOutput = unsafePerformIO $ internalInspect configTracer id @@ -848,9 +883,13 @@ -- | The exception thrown by `waitUntilTimeout`. -- -- @since 0.1.0.0 -newtype TimeoutException = TimeoutException +data TimeoutException = TimeoutException { -- | The id of the underlying container that was not ready in time. - id :: ContainerId + id :: ContainerId, + -- | The image tag of the container + imageName :: Maybe ImageTag, + -- | The container name + containerName :: Maybe Text } deriving (Eq, Show) @@ -859,9 +898,13 @@ -- | The exception thrown by `waitForState`. -- -- @since 0.1.0.0 -newtype InvalidStateException = InvalidStateException +data InvalidStateException = InvalidStateException { -- | The id of the underlying container that was not ready in time. - id :: ContainerId + id :: ContainerId, + -- | The image tag of the container + imageName :: Maybe ImageTag, + -- | The container name + containerName :: Maybe Text } deriving stock (Eq, Show) @@ -872,7 +915,7 @@ -- -- @since 0.5.0.0 waitForState :: (State -> Bool) -> WaitUntilReady -waitForState isReady = WaitReady $ \Container {id} -> do +waitForState isReady = WaitReady $ \Container {id, image} -> do let wait = do Config {configTracer} <- ask @@ -880,6 +923,13 @@ internalInspect configTracer id let state = containerState inspectOutput + containerName = inspectOutput ^? Optics.key "Name" % Optics._String + exception = + InvalidStateException + { id = id, + imageName = Just (imageTag image), + containerName = containerName + } if isReady state then pure () @@ -887,10 +937,10 @@ case stateStatus state of Exited -> -- Once exited, state won't change! - throwM InvalidStateException {id} + throwM exception Dead -> -- Once dead, state won't change! - throwM InvalidStateException {id} + throwM exception _ -> do liftIO (threadDelay 500000) wait @@ -1071,8 +1121,15 @@ timeout (seconds * 1000000) $ runInIO (interpreter rest) case result of - Nothing -> - throwM $ TimeoutException {id} + Nothing -> do + let Container {image, inspectOutput} = container + containerName = inspectOutput ^? Optics.key "Name" % Optics._String + throwM $ + TimeoutException + { id, + imageName = Just (imageTag image), + containerName = containerName + } Just {} -> pure () WaitMany first second -> do @@ -1142,13 +1199,19 @@ -- | Get the IP address of a running Docker container using @docker inspect@. internalContainerIp :: Container -> Text -internalContainerIp Container {id, inspectOutput} = +internalContainerIp Container {id, inspectOutput, image} = case inspectOutput ^? Optics.key "NetworkSettings" % Optics.key "IPAddress" % Optics._String of - Nothing -> - throw $ InspectOutputUnexpected {id} + Nothing -> do + let containerName = inspectOutput ^? Optics.key "Name" % Optics._String + throw $ + InspectOutputUnexpected + { id, + imageName = Just (imageTag image), + containerName = containerName + } Just address -> address @@ -1157,7 +1220,7 @@ -- -- @since 0.5.0.0 containerAlias :: Container -> Text -containerAlias Container {id, inspectOutput} = +containerAlias Container {id, inspectOutput, image} = case inspectOutput ^? pre ( Optics.key "NetworkSettings" @@ -1167,10 +1230,13 @@ % Optics.values % Optics._String ) of - Nothing -> + Nothing -> do + let containerName = inspectOutput ^? Optics.key "Name" % Optics._String throw $ InspectOutputMissingNetwork - { id + { id, + imageName = Just (imageTag image), + containerName = containerName } Just alias -> alias @@ -1180,7 +1246,7 @@ -- -- @since 0.5.0.0 containerGateway :: Container -> Text -containerGateway Container {id, inspectOutput} = +containerGateway Container {id, inspectOutput, image} = case inspectOutput ^? pre ( Optics.key "NetworkSettings" @@ -1189,10 +1255,13 @@ % Optics.key "Gateway" % Optics._String ) of - Nothing -> + Nothing -> do + let containerName = inspectOutput ^? Optics.key "Name" % Optics._String throw $ InspectOutputMissingNetwork - { id + { id, + imageName = Just (imageTag image), + containerName = containerName } Just gatewayIp -> gatewayIp @@ -1201,7 +1270,7 @@ -- -- @since 0.1.0.0 containerPort :: Container -> Port -> Int -containerPort Container {id, inspectOutput} Port {port, protocol} = +containerPort Container {id, inspectOutput, image} Port {port, protocol} = let -- TODO also support UDP ports -- Using IsString so it works both with Text (aeson<2) and Aeson.Key (aeson>=2) textPort :: (IsString s) => s @@ -1219,11 +1288,14 @@ % Optics._String ) of Nothing -> - throw $ - UnknownPortMapping - { id, - port = textPort - } + let containerName = inspectOutput ^? Optics.key "Name" % Optics._String + in throw $ + UnknownPortMapping + { id, + port = textPort, + imageName = Just (imageTag image), + containerName = containerName + } Just hostPort -> read (unpack hostPort) 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 @@ -20,6 +20,7 @@ Pipe (..), LogConsumer, consoleLogConsumer, + prefixedLogConsumer, dockerFollowLogs, -- * Common abstractions for Docker resources @@ -38,6 +39,7 @@ import qualified Data.ByteString as ByteString import Data.Foldable (traverse_) import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) import System.Exit (ExitCode (..)) import qualified System.IO import qualified System.Process as Process @@ -81,15 +83,27 @@ } | InspectUnknownContainerId {id :: ContainerId} | InspectOutputInvalidJSON {id :: ContainerId} - | InspectOutputMissingNetwork {id :: ContainerId} - | InspectOutputUnexpected {id :: ContainerId} + | InspectOutputMissingNetwork + { id :: ContainerId, + imageName :: Maybe Text, + containerName :: Maybe Text + } + | InspectOutputUnexpected + { id :: ContainerId, + imageName :: Maybe Text, + containerName :: Maybe Text + } | UnknownPortMapping { -- | Id of the `Container` that we tried to lookup the -- port mapping. id :: ContainerId, -- | Textual representation of port mapping we were -- trying to look up. - port :: Text + port :: Text, + -- | The image tag of the container + imageName :: Maybe Text, + -- | The container name + containerName :: Maybe Text } deriving (Eq, Show) @@ -157,6 +171,20 @@ ByteString.hPut System.IO.stdout (ByteString.singleton 0x0a) Stderr -> do ByteString.hPutStr System.IO.stderr line + ByteString.hPut System.IO.stderr (ByteString.singleton 0x0a) + +-- | A 'LogConsumer' that prefixes with some prefix identifier. +-- This makes it easier to identify which containers/callsites produced which logs. +prefixedLogConsumer :: Text -> LogConsumer +prefixedLogConsumer prefix pipe line = do + let prefixText = "[" <> prefix <> "] " + prefixedLine = encodeUtf8 prefixText <> line + case pipe of + Stdout -> do + ByteString.hPutStr System.IO.stdout prefixedLine + ByteString.hPut System.IO.stdout (ByteString.singleton 0x0a) + Stderr -> do + ByteString.hPutStr System.IO.stderr prefixedLine ByteString.hPut System.IO.stderr (ByteString.singleton 0x0a) -- | Forwards container logs to a 'LogConsumer'. This is equivalent of calling @docker logs containerId --follow@ diff --git a/test/TestContainers/TastySpec.hs b/test/TestContainers/TastySpec.hs --- a/test/TestContainers/TastySpec.hs +++ b/test/TestContainers/TastySpec.hs @@ -27,6 +27,7 @@ waitUntilMappedPortReachable, waitUntilTimeout, withContainers, + withCopyFileToContainer, withFollowLogs, withNetwork, (&), @@ -77,6 +78,11 @@ & withNetwork net & setWaitingFor (waitForHttp "16686/tcp" "/" [200]) + + _postgres <- + run $ + containerRequest (fromTag "postgres:16-alpine") + & withCopyFileToContainer "test/data/init-script.sql" "/docker-entrypoint-initdb.d/" _helloWorld <- run $ diff --git a/test/data/init-script.sql b/test/data/init-script.sql new file mode 100644 --- /dev/null +++ b/test/data/init-script.sql @@ -0,0 +1,6 @@ + +create table customers ( + id bigint not null, + name varchar not null, + primary key (id) +); 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.1.0 +version: 0.5.2.0 synopsis: Docker containers for your integration tests. description: testcontainers is a Haskell library that provides a friendly API to @@ -18,6 +18,7 @@ extra-source-files: CHANGELOG.md README.md + test/data/init-script.sql tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 || ==9.8.2 @@ -54,7 +55,7 @@ , http-client >=0.5.14 && <1 , http-types >=0.12.3 && <1 , mtl >=2.2.2 && <3 - , network >=2.8.0 && <3.2 + , network >=2.8.0 && <3.3 , optics-core >=0.1 && <0.5 , process >=1.6.5 && <1.7 , random >=1.2 && <2