diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Revision history for testcontainer-hs +## 0.4.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) + +* BREAKING: Ports can be passed as both numbers as well as strings ala "80/tcp" or "9423/udp" (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/31) + +* BREAKING: Introduce TestContainer monad (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/29) + +* Ability to use Docker networks (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/32) + +* Some internal module reorganization (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/32) + +* Refined timeout handling for WaitUntilReady (@alexbiehl, https://github.com/testcontainers/testcontainers-hs/pull/30) + +* Moved repository under the [testcontainers](https://github.com/testcontainers) organization + ## 0.2.0.0 -- 2020-08-07 * Dependency rework (@blackheaven, https://github.com/alexbiehl/testcontainers-hs/pull/3) diff --git a/src/TestContainers.hs b/src/TestContainers.hs --- a/src/TestContainers.hs +++ b/src/TestContainers.hs @@ -1,116 +1,139 @@ -- | -- This module shall be used as entrypoint to the testcontainers library. It exports -- all the necessary types and functions for most common use-cases. --- module TestContainers - ( - - -- * Docker images - - M.ImageTag - - , M.Image - , M.imageTag + ( -- * Docker images + M.ImageTag, + M.Image, + M.imageTag, -- * Referring to Docker images - - , M.ToImage - , M.fromTag - , M.fromBuildContext - , M.build + M.ToImage, + M.fromTag, + M.fromBuildContext, + M.build, - -- * @docker run@ parameters + -- * @docker run@ parameters + M.ContainerRequest, + M.containerRequest, + M.setName, + M.setFixedName, + M.setSuffixedName, + M.setRandomName, + M.setCmd, + M.setVolumeMounts, + M.setRm, + M.setEnv, + M.setNetwork, + M.withNetwork, + M.withNetworkAlias, + M.setLink, + M.setExpose, + M.setWaitingFor, + M.withFollowLogs, - , M.ContainerRequest - , M.containerRequest + -- * Logs + M.LogConsumer, + M.consoleLogConsumer, - , M.setName - , M.setCmd - , M.setVolumeMounts - , M.setRm - , M.setEnv - , M.setLink - , M.setExpose - , M.setWaitingFor + -- * @docker network@ parameters + M.NetworkRequest, + M.networkRequest, + M.withDriver, + M.withIpv6, - -- * Running Docker containers (@docker run@) + -- * Creating networks + M.Network, + M.NetworkId, + M.createNetwork, - , M.Container - , M.containerIp - , M.containerPort - , M.containerReleaseKey - , M.containerImage + -- * Port + M.Port (..), - , M.run + -- * Running Docker containers (@docker run@) + M.Container, + M.containerAlias, + M.containerGateway, + M.containerIp, + M.containerPort, + M.containerAddress, + M.containerReleaseKey, + M.containerImage, + M.run, -- * Inspecting Docker containers - - , M.InspectOutput - , M.inspect + M.InspectOutput, + M.inspect, -- * Docker container lifecycle - - , M.stop - , M.kill - , M.rm - , M.withLogs + M.stop, + M.kill, + M.rm, + M.withLogs, -- * Readiness checks - - , M.WaitUntilReady + M.WaitUntilReady, -- ** Timeout for readiness checks + M.waitUntilTimeout, - , M.waitUntilTimeout + -- ** Wait for container exit + M.State, + M.Status (..), + M.stateError, + M.stateExitCode, + M.stateFinishedAt, + M.stateOOMKilled, + M.statePid, + M.stateStartedAt, + M.stateStatus, + M.waitForState, - -- ** Waiting on particular log lines + -- ** Predicates to assert container state + M.successfulExit, - , M.Pipe(..) - , M.waitWithLogs - , M.waitForLogLine + -- ** Waiting on particular log lines + M.Pipe (..), + M.waitWithLogs, + M.waitForLogLine, -- ** Wait until connection can be established + M.waitUntilMappedPortReachable, - , M.waitUntilMappedPortReachable + -- ** Wait until the http server responds with a specific status code + M.waitForHttp, -- * Monad - - , M.MonadDocker + M.MonadDocker, + M.TestContainer, -- * Configuration - - , Config(..) - , defaultDockerConfig - , determineConfig - - -- * - - , Tracer - , Trace(..) - , newTracer + Config (..), + defaultDockerConfig, + determineConfig, + Tracer, + Trace (..), + newTracer, -- * Exceptions - - , M.DockerException(..) - , M.TimeoutException(..) - , M.UnexpectedEndOfPipe(..) + M.DockerException (..), + M.TimeoutException (..), + M.UnexpectedEndOfPipe (..), -- * Misc. Docker functions - - , dockerHostOs - , isDockerOnLinux + dockerHostOs, + isDockerOnLinux, -- * Predefined Docker images - - , M.redis - , M.mongo + M.redis, + M.mongo, -- * Reexports - - , ResIO - , runResourceT - , (&) - ) where + ResIO, + runResourceT, + (&), + ) +where -import TestContainers.Docker as M -import TestContainers.Image as M +import TestContainers.Docker as M +import TestContainers.Image as M diff --git a/src/TestContainers/Config.hs b/src/TestContainers/Config.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Config.hs @@ -0,0 +1,34 @@ +module TestContainers.Config + ( Config (..), + defaultConfig, + defaultDockerConfig, + determineConfig, + ) +where + +import {-# SOURCE #-} TestContainers.Docker (createRyukReaper) +import TestContainers.Monad (Config (..)) + +-- | Default configuration. +-- +-- @since 0.4.0.0 +defaultConfig :: Config +defaultConfig = + Config + { configDefaultWaitTimeout = Just 60, + configTracer = mempty, + configCreateReaper = createRyukReaper + } + +-- | Default configuration. +-- +-- @since 0.2.0.0 +defaultDockerConfig :: Config +defaultDockerConfig = + defaultConfig + +-- | Autoselect the default configuration depending on wether you use Docker For +-- Mac or not. +determineConfig :: IO Config +determineConfig = + pure defaultDockerConfig diff --git a/src/TestContainers/Docker.hs b/src/TestContainers/Docker.hs --- a/src/TestContainers/Docker.hs +++ b/src/TestContainers/Docker.hs @@ -1,1059 +1,1233 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -module TestContainers.Docker - ( - MonadDocker - - -- * Configuration - - , Config(..) - , defaultDockerConfig - , determineConfig - - -- * Exeuction tracing - - , Tracer - , Trace(..) - , newTracer - , withTrace - - -- * Docker image - - , ImageTag - - , Image - , imageTag - - -- * Docker container - - , ContainerId - , Container - - , containerId - , containerImage - , containerIp - , containerPort - , containerReleaseKey - - -- * Referring to images - - , ToImage - - , fromTag - , fromBuildContext - , fromDockerfile - - , build - - -- * Exceptions - - , DockerException(..) - - -- * Running containers - - , ContainerRequest - , containerRequest - , setName - , setCmd - , setVolumeMounts - , setRm - , setEnv - , setLink - , setExpose - , setWaitingFor - , run - - -- * Managing the container lifecycle - - , InspectOutput - , inspect - - , stop - , kill - , rm - , withLogs - - -- * Wait for containers to become ready - , WaitUntilReady - , waitUntilReady - - -- * Only block for defined amounts of time - , TimeoutException(..) - , waitUntilTimeout - - -- * Wait until a specific pattern appears in the logs - , waitWithLogs - , UnexpectedEndOfPipe(..) - , Pipe(..) - , waitForLogLine - - -- * Misc. Docker functions - - , dockerHostOs - , isDockerOnLinux - - -- * Wait until a socket is reachable - , waitUntilMappedPortReachable - - -- * Reexports for convenience - , ResIO - , runResourceT - - , (&) - ) where - -import Control.Applicative ((<|>)) -import Control.Concurrent (threadDelay) -import Control.Exception (IOException, throw) -import Control.Monad.Catch (Exception, MonadCatch, MonadMask, - MonadThrow, bracket, throwM, try) -import Control.Monad.Fix (mfix) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) -import Control.Monad.Reader (MonadReader (..), runReaderT) -import Control.Monad.Trans.Resource (MonadResource (liftResourceT), - ReleaseKey, ResIO, register, - runResourceT) -import Data.Aeson (Value, decode') -import qualified Data.Aeson.Optics as Optics -import qualified Data.ByteString.Lazy.Char8 as LazyByteString -import Data.Foldable (traverse_) -import Data.Function ((&)) -import Data.List (find) -import Data.Text (Text, pack, strip, unpack) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Encoding as LazyText -import GHC.Stack (withFrozenCallStack) -import qualified Network.Socket as Socket -import Optics.Fold (pre) -import Optics.Operators ((^?)) -import Optics.Optic ((%)) -import Prelude hiding (error, id) -import qualified Prelude -import System.Exit (ExitCode (..)) -import System.IO (Handle, hClose) -import System.IO.Unsafe (unsafePerformIO) -import qualified System.Process as Process -import System.Timeout (timeout) - - --- | Type representing various events during testcontainer execution. -data Trace - -- | The low-level invocation of @docker@ command - -- - -- @ - -- TraceDockerInvocation args stdin exitcode - -- @ - = TraceDockerInvocation [Text] Text ExitCode -- docker [args] [stdin] - -- | Line written to STDOUT by a Docker process. - | TraceDockerStdout Text - -- | Line written to STDERR by a Docker process. - | TraceDockerStderr Text - -- | Waiting for a container to become ready. Attached with the - -- timeout to wait (in seconds). - | TraceWaitUntilReady (Maybe Int) - -- | Opening socket - | TraceOpenSocket Text Int (Maybe IOException) - - -deriving stock instance Eq Trace -deriving stock instance Show Trace - - --- | Traces execution within testcontainers library. -newtype Tracer = Tracer { unTracer :: Trace -> IO () } - - -deriving newtype instance Semigroup Tracer -deriving newtype instance Monoid Tracer - - --- | Construct a new `Tracer` from a tracing function. -newTracer - :: (Trace -> IO ()) - -> Tracer -newTracer action = Tracer - { - unTracer = action - } - - -withTrace :: MonadIO m => Tracer -> Trace -> m () -withTrace tracer trace = - liftIO $ unTracer tracer trace -{-# INLINE withTrace #-} - - --- | Configuration for defaulting behavior. --- --- @since 0.2.0.0 --- -data Config = Config - { - -- | The number of seconds to maximally wait for a container to - -- become ready. Default is `Just 60`. - -- - -- @Nothing@ <=> waits indefinitely. - configDefaultWaitTimeout :: Maybe Int - -- | Traces execution inside testcontainers library. - , configTracer :: Tracer - } - - --- | Default configuration. --- --- @since 0.2.0.0 --- -defaultDockerConfig :: Config -defaultDockerConfig = Config - { - configDefaultWaitTimeout = Just 60 - , configTracer = mempty - } - - --- | Autoselect the default configuration depending on wether you use Docker For --- Mac or not. -determineConfig :: IO Config -determineConfig = - pure defaultDockerConfig - - --- | Failing to interact with Docker results in this exception --- being thrown. --- --- @since 0.1.0.0 --- -data DockerException - = DockerException - { - -- | Exit code of the underlying Docker process. - exitCode :: ExitCode - -- | Arguments that were passed to Docker. - , args :: [Text] - -- | Docker's STDERR output. - , stderr :: Text - } - | InspectUnknownContainerId { id :: ContainerId } - | InspectOutputInvalidJSON { id :: ContainerId } - | InspectOutputUnexpected { id :: ContainerId } - | 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 - } - deriving (Eq, Show) - - -instance Exception DockerException - - --- | Docker related functionality is parameterized over this `Monad`. --- --- @since 0.1.0.0 --- -type MonadDocker m = - (MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, MonadResource m, MonadReader Config m) - - --- | Parameters for a running a Docker container. --- --- @since 0.1.0.0 --- -data ContainerRequest = ContainerRequest - { - toImage :: ToImage - , cmd :: Maybe [Text] - , env :: [(Text, Text)] - , exposedPorts :: [Int] - , volumeMounts :: [(Text, Text)] - , links :: [ContainerId] - , name :: Maybe Text - , rmOnExit :: Bool - , readiness :: Maybe WaitUntilReady - } - - --- | Default `ContainerRequest`. Used as base for every Docker container. --- --- @since 0.1.0.0 --- -containerRequest :: ToImage -> ContainerRequest -containerRequest image = ContainerRequest - { - toImage = image - , name = Nothing - , cmd = Nothing - , env = [] - , exposedPorts = [] - , volumeMounts = [] - , links = [] - , rmOnExit = True - , readiness = Nothing - } - - --- | Set the name of a Docker container. This is equivalent to invoking @docker run@ --- with the @--name@ parameter. --- --- @since 0.1.0.0 --- -setName :: Text -> ContainerRequest -> ContainerRequest -setName newName req = - -- TODO error on empty Text - req { name = Just newName } - - --- | The command to execute inside the Docker container. This is the equivalent --- of passing the command on the @docker run@ invocation. --- --- @since 0.1.0.0 --- -setCmd :: [Text] -> ContainerRequest -> ContainerRequest -setCmd newCmd req = - req { cmd = Just newCmd } - - --- | 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 -setVolumeMounts newVolumeMounts req = - req { volumeMounts = newVolumeMounts } - --- | Wether to remove the container once exited. This is equivalent to passing --- @--rm@ to @docker run@. (default is `True`). --- --- @since 0.1.0.0 --- -setRm :: Bool -> ContainerRequest -> ContainerRequest -setRm newRm req = - req { rmOnExit = newRm } - - --- | Set the environment for the container. This is equivalent to passing @--env key=value@ --- to @docker run@. --- --- @since 0.1.0.0 --- -setEnv :: [(Text, Text)] -> ContainerRequest -> ContainerRequest -setEnv newEnv req = - req { env = newEnv } - - --- | Set link on the container. This is equivalent to passing @--link other_container@ --- to @docker run@. --- --- @since 0.1.0.0 --- -setLink :: [ContainerId] -> ContainerRequest -> ContainerRequest -setLink newLink req = - req { links = newLink } - - --- | Set exposed ports on the container. This is equivalent to setting @--publish $PORT@ to --- @docker run@. Docker assigns a random port for the host port. You will have to use `containerIp` --- and `containerPort` to connect to the published port. --- --- @ --- container <- `run` $ `containerRequest` `redis` & `setExpose` [ 6379 ] --- let (redisHost, redisPort) = (`containerIp` container, `containerPort` container 6379) --- print (redisHost, redisPort) --- @ --- --- @since 0.1.0.0 --- -setExpose :: [Int] -> ContainerRequest -> ContainerRequest -setExpose newExpose req = - req { exposedPorts = newExpose } - - --- | Set the waiting strategy on the container. Depending on a Docker container --- it can take some time until the provided service is ready. You will want to --- use to `setWaitingFor` to block until the container is ready to use. --- --- @since 0.1.0.0 --- -setWaitingFor :: WaitUntilReady -> ContainerRequest -> ContainerRequest -setWaitingFor newWaitingFor req = - req { readiness = Just newWaitingFor } - - --- | Runs a Docker container from an `Image` and `ContainerRequest`. A finalizer --- is registered so that the container is aways stopped when it goes out of scope. --- This function is essentially @docker run@. --- --- @since 0.1.0.0 --- -run :: MonadDocker m => ContainerRequest -> m Container -run request = do - - let - ContainerRequest - { - toImage - , name - , cmd - , env - , exposedPorts - , volumeMounts - , links - , rmOnExit - , readiness - } = request - - image@Image{ tag } <- runToImage toImage - - let - dockerRun :: [Text] - dockerRun = concat $ - [ [ "run" ] ] ++ - [ [ "--detach" ] ] ++ - [ [ "--name", containerName ] | Just containerName <- [name] ] ++ - [ [ "--env", variable <> "=" <> value ] | (variable, value) <- env ] ++ - [ [ "--publish", pack (show port)] | port <- exposedPorts ] ++ - [ [ "--link", container ] | container <- links ] ++ - [ [ "--volume", src <> ":" <> dest ] | (src, dest) <- volumeMounts ] ++ - [ [ "--rm" ] | rmOnExit ] ++ - [ [ tag ] ] ++ - [ command | Just command <- [cmd] ] - - config@Config { configTracer } <- ask - - stdout <- docker configTracer dockerRun - - let - id :: ContainerId - !id = - -- N.B. Force to not leak STDOUT String - strip (pack stdout) - - -- Careful, this is really meant to be lazy - ~inspectOutput = unsafePerformIO $ - internalInspect configTracer id - - container <- liftResourceT $ mfix $ \container -> do - -- Note: We have to tie the knot as the resulting container - -- carries the release key as well. - releaseKey <- register $ runReaderT (runResourceT (stop container)) config - pure $ Container - { - id - , releaseKey - , image - , inspectOutput - , config - } - - case readiness of - Just wait -> - waitUntilReady container wait - Nothing -> - pure () - - pure container - - --- | Internal function that runs Docker. Takes care of throwing an exception --- in case of failure. --- --- @since 0.1.0.0 --- -docker :: MonadIO m => Tracer -> [Text] -> m String -docker tracer args = - dockerWithStdin tracer args "" - - --- | Internal function that runs Docker. Takes care of throwing an exception --- in case of failure. --- --- @since 0.1.0.0 --- -dockerWithStdin :: MonadIO m => Tracer -> [Text] -> Text -> m String -dockerWithStdin tracer args stdin = liftIO $ do - (exitCode, stdout, stderr) <- Process.readProcessWithExitCode "docker" - (map unpack args) (unpack stdin) - - withTrace tracer (TraceDockerInvocation args stdin exitCode) - - -- TODO output these concurrently with the process - traverse_ (withTrace tracer . TraceDockerStdout . pack) (lines stdout) - traverse_ (withTrace tracer . TraceDockerStderr . pack) (lines stderr) - - case exitCode of - ExitSuccess -> pure stdout - _ -> throwM $ DockerException - { - exitCode, args - , stderr = pack stderr - } - - --- | Kills a Docker container. `kill` is essentially @docker kill@. --- --- @since 0.1.0.0 --- -kill :: MonadDocker m => Container -> m () -kill Container { id } = do - tracer <- askTracer - _ <- docker tracer [ "kill", id ] - return () - - --- | Stops a Docker container. `stop` is essentially @docker stop@. --- --- @since 0.1.0.0 --- -stop :: MonadDocker m => Container -> m () -stop Container { id } = do - tracer <- askTracer - _ <- docker tracer [ "stop", id ] - return () - - --- | Remove a Docker container. `rm` is essentially @docker rm -f@ --- --- @since 0.1.0.0 --- -rm :: MonadDocker m => Container -> m () -rm Container { id } = do - tracer <- askTracer - _ <- docker tracer [ "rm", "-f", "-v", id ] - return () - - --- | Access STDOUT and STDERR of a running Docker container. This is essentially --- @docker logs@ under the hood. --- --- @since 0.1.0.0 --- -withLogs :: forall m a . MonadDocker m => Container -> (Handle -> Handle -> m a) -> m a -withLogs Container { id } logger = do - - let - acquire :: m (Handle, Handle, Handle, Process.ProcessHandle) - acquire = - liftIO $ Process.runInteractiveProcess - "docker" - [ "logs", "--follow", unpack id ] - Nothing - Nothing - - release :: (Handle, Handle, Handle, Process.ProcessHandle) -> m () - release (stdin, stdout, stderr, handle) = - liftIO $ Process.cleanupProcess - (Just stdin, Just stdout, Just stderr, handle) - - bracket acquire release $ \(stdin, stdout, stderr, _handle) -> do - -- No need to keep it around... - liftIO $ hClose stdin - logger stdout stderr - - --- | A tag to a Docker image. --- --- @since 0.1.0.0 --- -type ImageTag = Text - - --- | A description of how to build an `Image`. --- --- @since 0.1.0.0 --- -data ToImage = ToImage - { - runToImage :: forall m. MonadDocker m => m Image - , applyToContainerRequest :: ContainerRequest -> ContainerRequest - } - - --- | Build the `Image` referred to by the argument. If the construction of the --- image is expensive (e.g. a call to `fromBuildContext`) we don't want to --- repeatedly build the image. Instead, `build` can be used to execute the --- underlying Docker build once and re-use the resulting `Image`. --- --- @since 0.1.0.0 --- -build :: MonadDocker m => ToImage -> m ToImage -build toImage@ToImage { applyToContainerRequest } = do - image <- runToImage toImage - return $ ToImage - { - runToImage = pure image - , applyToContainerRequest - } - - --- | Default `ToImage`. Doesn't apply anything to to `ContainerRequests`. --- --- @since 0.1.0.0 --- -defaultToImage :: (forall m . MonadDocker m => m Image) -> ToImage -defaultToImage action = ToImage - { - runToImage = action - , applyToContainerRequest = \x -> x - } - - --- | Get an `Image` from a tag. --- --- @since 0.1.0.0 --- -fromTag :: ImageTag -> ToImage -fromTag tag = defaultToImage $ do - tracer <- askTracer - output <- docker tracer [ "pull", "--quiet", tag ] - return $ Image - { - tag = strip (pack output) - } - - --- | Build the image from a build path and an optional path to the --- Dockerfile (default is Dockerfile) --- --- @since 0.1.0.0 --- -fromBuildContext - :: FilePath - -> Maybe FilePath - -> ToImage -fromBuildContext path mdockerfile = defaultToImage $ do - let - args - | Just dockerfile <- mdockerfile = - [ "build", "--quiet", "-f", pack dockerfile, pack path ] - | otherwise = - [ "build", "--quiet", pack path ] - tracer <- askTracer - output <- docker tracer args - return $ Image - { - tag = strip (pack output) - } - - --- | Build a contextless image only from a Dockerfile passed as `Text`. --- --- @since 0.1.0.0 --- -fromDockerfile - :: Text - -> ToImage -fromDockerfile dockerfile = defaultToImage $ do - tracer <- askTracer - output <- dockerWithStdin tracer [ "build", "--quiet", "-" ] dockerfile - return $ Image - { - tag = strip (pack output) - } - - --- | Identifies a container within the Docker runtime. Assigned by @docker run@. --- --- @since 0.1.0.0 --- -type ContainerId = Text - - --- | A strategy that describes how to asses readiness of a `Container`. Allows --- Users to plug in their definition of readiness. --- --- @since 0.1.0.0 --- -newtype WaitUntilReady = WaitUntilReady - { - checkContainerReady :: Config -> Container -> (Maybe Int, ResIO ()) - } - - --- | The exception thrown by `waitForLine` in case the expected log line --- wasn't found. --- --- @since 0.1.0.0 --- -newtype UnexpectedEndOfPipe = UnexpectedEndOfPipe - { - -- | The id of the underlying container. - id :: ContainerId - } - deriving (Eq, Show) - - -instance Exception UnexpectedEndOfPipe - - --- | The exception thrown by `waitUntilTimeout`. --- --- @since 0.1.0.0 --- -newtype TimeoutException = TimeoutException - { - -- | The id of the underlying container that was not ready in time. - id :: ContainerId - } - deriving (Eq, Show) - - -instance Exception TimeoutException - - --- | @waitUntilTimeout n waitUntilReady@ waits @n@ seconds for the container --- to be ready. If the container is not ready by then a `TimeoutException` will --- be thrown. --- --- @since 0.1.0.0 --- -waitUntilTimeout :: Int -> WaitUntilReady -> WaitUntilReady -waitUntilTimeout seconds wait = WaitUntilReady $ \config container -> - case checkContainerReady wait config container of - (Nothing, check) -> - (Just seconds, check) - (Just innerTimeout, check) - | innerTimeout > seconds -> - (Just seconds, check) - | otherwise -> - (Just innerTimeout, check) - - --- | Waits until the port of a container is ready to accept connections. --- This combinator should always be used with `waitUntilTimeout`. --- --- @since 0.1.0.0 --- -waitUntilMappedPortReachable - :: Int - -> WaitUntilReady -waitUntilMappedPortReachable port = WaitUntilReady $ \config container -> - withFrozenCallStack $ - - let - Config { configTracer } = config - - -- TODO add a parameterizable function when we will support host - -- mapping exposure - hostIp :: String - hostIp = "0.0.0.0" - - hostPort :: Int - hostPort = containerPort container port - - resolve = do - let hints = Socket.defaultHints { Socket.addrSocketType = Socket.Stream } - head <$> Socket.getAddrInfo (Just hints) (Just hostIp) (Just (show hostPort)) - - open addr = do - socket <- Socket.socket - (Socket.addrFamily addr) - (Socket.addrSocketType addr) - (Socket.addrProtocol addr) - Socket.connect - socket - (Socket.addrAddress addr) - pure socket - - retry = do - result <- try (resolve >>= open) - case result of - Right socket -> do - withTrace configTracer (TraceOpenSocket (pack hostIp) hostPort Nothing) - Socket.close socket - pure () - - Left (exception :: IOException) -> do - withTrace configTracer - (TraceOpenSocket (pack hostIp) hostPort (Just exception)) - threadDelay 500000 - retry - - in - (Nothing, liftIO retry) - - --- | A low-level primitive that allows scanning the logs for specific log lines --- that indicate readiness of a container. --- --- The `Handle`s passed to the function argument represent @stdout@ and @stderr@ --- of the container. --- --- @since 0.1.0.0 --- -waitWithLogs :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady -waitWithLogs waiter = WaitUntilReady $ \config container -> - let - check = flip runReaderT config $ withLogs container $ \stdout stderr -> - liftIO $ waiter container stdout stderr - in - (Nothing, check) - - --- | A data type indicating which pipe to scan for a specific log line. --- --- @since 0.1.0.0 --- -data Pipe - -- | Refer to logs on STDOUT. - = Stdout - -- | Refer to logs on STDERR. - | Stderr - deriving (Eq, Ord, Show) - - --- | Waits for a specific line to occur in the logs. Throws a `UnexpectedEndOfPipe` --- exception in case the desired line can not be found on the logs. --- --- Say you want to find "Ready to accept connections" in the logs on Stdout try: --- --- @ --- waitForLogLine Stdout ("Ready to accept connections" ``LazyText.isInfixOf``) --- @ --- --- @since 0.1.0.0 --- -waitForLogLine :: Pipe -> (LazyText.Text -> Bool) -> WaitUntilReady -waitForLogLine whereToLook matches = waitWithLogs $ \Container { id } stdout stderr -> do - let - logs :: Handle - logs = case whereToLook of - Stdout -> stdout - Stderr -> stderr - - logContent <- LazyByteString.hGetContents logs - - let - logLines :: [LazyText.Text] - logLines = - -- FIXME: This is assuming UTF8 encoding. Do better! - map - (LazyText.decodeUtf8With lenientDecode) - (LazyByteString.lines logContent) - - case find matches logLines of - Just _ -> pure () - Nothing -> throwM $ UnexpectedEndOfPipe { id } - - --- | Blocks until the container is ready. `waitUntilReady` might throw exceptions --- depending on the used `WaitUntilReady` on the container. --- --- @since 0.1.0.0 --- -waitUntilReady :: MonadDocker m => Container -> WaitUntilReady -> m () -waitUntilReady container@Container { id } waiter = do - config@Config { configDefaultWaitTimeout, configTracer } <- ask - let - (timeoutInSeconds, check) = - checkContainerReady waiter config container - - runAction action timeoutSeconds = do - withTrace configTracer (TraceWaitUntilReady timeoutSeconds) - action - - withTimeout action = case timeoutInSeconds <|> configDefaultWaitTimeout of - Nothing -> - runAction action Nothing - Just seconds -> - withRunInIO $ \runInIO -> do - result <- timeout (seconds * 1000000) $ runInIO (runAction action (Just seconds)) - case result of - Nothing -> - throwM $ TimeoutException { id } - Just _ -> - pure () - - liftResourceT (withTimeout check) - - --- | Handle to a Docker image. --- --- @since 0.1.0.0 --- -data Image = Image - { - -- | The image tag assigned by Docker. Uniquely identifies an `Image` - -- within Docker. - tag :: ImageTag - } - deriving (Eq, Show) - - --- | The image tag assigned by Docker. Uniquely identifies an `Image` --- within Docker. --- --- @since 0.1.0.0 --- -imageTag :: Image -> ImageTag -imageTag Image { tag } = tag - - --- | Handle to a Docker container. --- --- @since 0.1.0.0 --- -data Container = Container - { - -- | The container Id assigned by Docker, uniquely identifying this `Container`. - id :: ContainerId - -- | Underlying `ReleaseKey` for the resource finalizer. - , releaseKey :: ReleaseKey - -- | The underlying `Image` of this container. - , image :: Image - -- | Configuration used to create and run this container. - , config :: Config - -- | Memoized output of `docker inspect`. This is being calculated lazily. - , inspectOutput :: InspectOutput - } - - --- | The parsed JSON output of docker inspect command. --- --- @since 0.1.0.0 --- -type InspectOutput = Value - - --- | Returns the id of the container. --- --- @since 0.1.0.0 --- -containerId :: Container -> ContainerId -containerId Container { id } = id - - --- | Returns the underlying image of the container. --- --- @since 0.1.0.0 --- -containerImage :: Container -> Image -containerImage Container { image } = image - - --- | Returns the internal release key used for safely shutting down --- the container. Use this with care. This function is considered --- an internal detail. --- --- @since 0.1.0.0 --- -containerReleaseKey :: Container -> ReleaseKey -containerReleaseKey Container { releaseKey } = releaseKey - - --- | Looks up the ip address of the container. --- --- @since 0.1.0.0 --- -containerIp :: Container -> Text -containerIp = - internalContainerIp - - --- | Get the IP address of a running Docker container using @docker inspect@. -internalContainerIp :: Container -> Text -internalContainerIp Container { id, inspectOutput } = - case inspectOutput - ^? Optics.key "NetworkSettings" - % Optics.key "IPAddress" - % Optics._String of - - Nothing -> - throw $ InspectOutputUnexpected { id } - - Just address -> - address - - --- | Looks up an exposed port on the host. --- --- @since 0.1.0.0 --- -containerPort :: Container -> Int -> Int -containerPort Container { id, inspectOutput } port = - let - -- TODO also support UDP ports - textPort :: Text - textPort = pack (show port) <> "/tcp" - in - -- TODO be more mindful, make sure to grab the - -- port from the right host address - - case inspectOutput - ^? pre (Optics.key "NetworkSettings" - % Optics.key "Ports" - % Optics.key textPort - % Optics.values - % Optics.key "HostPort" - % Optics._String) of - - Nothing -> - throw $ UnknownPortMapping - { - id - , port = textPort - } - Just hostPort -> - read (unpack hostPort) - - --- | Runs the `docker inspect` command. Memoizes the result. --- --- @since 0.1.0.0 --- -inspect :: MonadDocker m => Container -> m InspectOutput -inspect Container { inspectOutput } = - pure inspectOutput - - --- | Runs the `docker inspect` command. --- --- @since 0.1.0.0 --- -internalInspect :: (MonadThrow m, MonadIO m) => Tracer -> ContainerId -> m InspectOutput -internalInspect tracer id = do - stdout <- docker tracer [ "inspect", id ] - case decode' (LazyByteString.pack stdout) of - Nothing -> - throwM $ InspectOutputInvalidJSON { id } - Just [] -> - throwM $ InspectUnknownContainerId { id } - Just [value] -> - pure value - Just _ -> - Prelude.error "Internal: Multiple results where I expected single result" - - -askTracer :: MonadReader Config m => m Tracer -askTracer = do - Config { configTracer } <- ask - pure configTracer -{-# INLINE askTracer #-} - - -dockerHostOs :: MonadDocker m => m Text -dockerHostOs = do - tracer <- askTracer - strip . pack <$> docker tracer [ "version", "--format", "{{.Server.Os}}" ] - - -isDockerOnLinux :: MonadDocker m => m Bool -isDockerOnLinux = - ("linux" ==) <$> dockerHostOs +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module TestContainers.Docker + ( MonadDocker, + TestContainer, + + -- * Configuration + Config (..), + defaultDockerConfig, + determineConfig, + + -- * Exeuction tracing + Tracer, + Trace (..), + newTracer, + withTrace, + + -- * Docker image + ImageTag, + Image, + imageTag, + + -- * Port + Port (..), + + -- * Docker container + ContainerId, + Container, + containerId, + containerImage, + containerAlias, + containerGateway, + containerIp, + containerPort, + containerAddress, + containerReleaseKey, + + -- * Container state + State, + Status (..), + stateError, + stateExitCode, + stateFinishedAt, + stateOOMKilled, + statePid, + stateStartedAt, + stateStatus, + + -- * Predicates to assert container state + successfulExit, + + -- * Referring to images + ToImage, + fromTag, + fromBuildContext, + fromDockerfile, + build, + + -- * Exceptions + DockerException (..), + + -- * Running containers + ContainerRequest, + containerRequest, + withLabels, + setName, + setFixedName, + setSuffixedName, + setRandomName, + setCmd, + setVolumeMounts, + setRm, + setEnv, + setNetwork, + withNetwork, + withNetworkAlias, + setLink, + setExpose, + setWaitingFor, + run, + + -- * Following logs + LogConsumer, + consoleLogConsumer, + withFollowLogs, + + -- * Network related functionality + NetworkId, + Network, + NetworkRequest, + networkId, + networkRequest, + createNetwork, + withIpv6, + withDriver, + + -- * Managing the container lifecycle + InspectOutput, + inspect, + stop, + kill, + rm, + withLogs, + + -- * Wait for containers to become ready + WaitUntilReady, + waitUntilReady, + + -- * Only block for defined amounts of time + TimeoutException (..), + waitUntilTimeout, + + -- * Wait for container state + waitForState, + + -- * Wait until a specific pattern appears in the logs + waitWithLogs, + Pipe (..), + UnexpectedEndOfPipe (..), + waitForLogLine, + + -- * Misc. Docker functions + dockerHostOs, + isDockerOnLinux, + + -- * Wait until a socket is reachable + waitUntilMappedPortReachable, + + -- * Wait until the http server responds with a specific status code + waitForHttp, + + -- * Reaper + createRyukReaper, + + -- * Reexports for convenience + ResIO, + runResourceT, + (&), + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (IOException, throw) +import Control.Monad (forM_, replicateM, unless) +import Control.Monad.Catch + ( Exception, + MonadCatch, + MonadThrow, + bracket, + throwM, + try, + ) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.Trans.Resource + ( ReleaseKey, + ResIO, + register, + runResourceT, + ) +import Data.Aeson (decode') +import qualified Data.Aeson.Optics as Optics +import qualified Data.ByteString.Lazy.Char8 as LazyByteString +import Data.Function ((&)) +import Data.List (find) +import Data.String (IsString (..)) +import Data.Text (Text, pack, splitOn, strip, unpack) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Encoding as LazyText +import Data.Text.Read (decimal) +import GHC.Stack (withFrozenCallStack) +import Network.HTTP.Client + ( HttpException, + Manager, + Request (..), + defaultManagerSettings, + defaultRequest, + httpNoBody, + newManager, + responseStatus, + ) +import Network.HTTP.Types (statusCode) +import qualified Network.Socket as Socket +import Optics.Fold (pre) +import Optics.Operators ((^?)) +import Optics.Optic ((%)) +import System.Directory (doesFileExist) +import System.IO (Handle, hClose) +import System.IO.Unsafe (unsafePerformIO) +import qualified System.Process as Process +import qualified System.Random as Random +import System.Timeout (timeout) +import TestContainers.Config + ( Config (..), + defaultDockerConfig, + determineConfig, + ) +import TestContainers.Docker.Internal + ( ContainerId, + DockerException (..), + InspectOutput, + LogConsumer, + Pipe (..), + consoleLogConsumer, + docker, + dockerFollowLogs, + dockerWithStdin, + ) +import TestContainers.Docker.Network + ( Network, + NetworkId, + NetworkRequest, + createNetwork, + networkId, + networkRequest, + withDriver, + withIpv6, + ) +import TestContainers.Docker.Reaper + ( Reaper, + newRyukReaper, + reaperLabels, + ryukImageTag, + ryukPort, + ) +import TestContainers.Docker.State + ( State, + Status (..), + containerState, + stateError, + stateExitCode, + stateFinishedAt, + stateOOMKilled, + statePid, + stateStartedAt, + stateStatus, + ) +import TestContainers.Monad + ( MonadDocker, + TestContainer, + ) +import TestContainers.Trace (Trace (..), Tracer, newTracer, withTrace) +import Prelude hiding (error, id) +import qualified Prelude + +-- | Parameters for a running a Docker container. +-- +-- @since 0.1.0.0 +data ContainerRequest = ContainerRequest + { toImage :: ToImage, + cmd :: Maybe [Text], + env :: [(Text, Text)], + exposedPorts :: [Port], + volumeMounts :: [(Text, Text)], + network :: Maybe (Either Network Text), + networkAlias :: Maybe Text, + links :: [ContainerId], + naming :: NamingStrategy, + rmOnExit :: Bool, + readiness :: WaitUntilReady, + labels :: [(Text, Text)], + noReaper :: Bool, + followLogs :: Maybe LogConsumer + } + +-- | Parameters for a naming a Docker container. +-- +-- @since 0.4.0.0 +data NamingStrategy + = RandomName + | FixedName Text + | SuffixedName Text + +-- | Default `ContainerRequest`. Used as base for every Docker container. +-- +-- @since 0.1.0.0 +containerRequest :: ToImage -> ContainerRequest +containerRequest image = + ContainerRequest + { toImage = image, + naming = RandomName, + cmd = Nothing, + env = [], + exposedPorts = [], + volumeMounts = [], + network = Nothing, + networkAlias = Nothing, + links = [], + rmOnExit = False, + readiness = mempty, + labels = mempty, + noReaper = False, + followLogs = Nothing + } + +-- | Set the name of a Docker container. This is equivalent to invoking @docker run@ +-- with the @--name@ parameter. +-- +-- @since 0.1.0.0 +setName :: Text -> ContainerRequest -> ContainerRequest +setName = setFixedName +{-# DEPRECATED setName "See setFixedName" #-} + +-- | Set the name of a Docker container. This is equivalent to invoking @docker run@ +-- with the @--name@ parameter. +-- +-- @since 0.4.0.0 +setFixedName :: Text -> ContainerRequest -> ContainerRequest +setFixedName newName req = + -- TODO error on empty Text + req {naming = FixedName newName} + +-- | Set the name randomly given of a Docker container. This is equivalent to omitting +-- the @--name@ parameter calling @docker run@. +-- +-- @since 0.4.0.0 +setRandomName :: ContainerRequest -> ContainerRequest +setRandomName req = + -- TODO error on empty Text + req {naming = RandomName} + +-- | Set the name randomly suffixed of a Docker container. This is equivalent to invoking +-- @docker run@ with the @--name@ parameter. +-- +-- @since 0.4.0.0 +setSuffixedName :: Text -> ContainerRequest -> ContainerRequest +setSuffixedName preffix req = + -- TODO error on empty Text + req {naming = SuffixedName preffix} + +-- | The command to execute inside the Docker container. This is the equivalent +-- of passing the command on the @docker run@ invocation. +-- +-- @since 0.1.0.0 +setCmd :: [Text] -> ContainerRequest -> ContainerRequest +setCmd newCmd req = + req {cmd = Just newCmd} + +-- | 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 +setVolumeMounts newVolumeMounts req = + req {volumeMounts = newVolumeMounts} + +-- | Wether to remove the container once exited. This is equivalent to passing +-- @--rm@ to @docker run@. (default is `True`). +-- +-- @since 0.1.0.0 +setRm :: Bool -> ContainerRequest -> ContainerRequest +setRm newRm req = + req {rmOnExit = newRm} + +-- | Set the environment for the container. This is equivalent to passing @--env key=value@ +-- to @docker run@. +-- +-- @since 0.1.0.0 +setEnv :: [(Text, Text)] -> ContainerRequest -> ContainerRequest +setEnv newEnv req = + req {env = newEnv} + +-- | Set the network the container will connect to. This is equivalent to passing +-- @--network network_name@ to @docker run@. +-- +-- @since 0.4.0.0 +setNetwork :: Text -> ContainerRequest -> ContainerRequest +setNetwork networkName req = + req {network = Just (Right networkName)} + +-- | Set the network the container will connect to. This is equivalent to passing +-- @--network network_name@ to @docker run@. +-- +-- @since 0.4.0.0 +withNetwork :: Network -> ContainerRequest -> ContainerRequest +withNetwork network req = + req {network = Just (Left network)} + +-- | Set the network alias for this container. This is equivalent to passing +-- @--network-alias alias@ to @docker run@. +-- +-- @since 0.4.0.0 +withNetworkAlias :: Text -> ContainerRequest -> ContainerRequest +withNetworkAlias alias req = + req {networkAlias = Just alias} + +-- | Sets labels for a container +-- +-- @since 0.4.0.0 +withLabels :: [(Text, Text)] -> ContainerRequest -> ContainerRequest +withLabels xs request = + request {labels = xs} + +-- | Set link on the container. This is equivalent to passing @--link other_container@ +-- to @docker run@. +-- +-- @since 0.1.0.0 +setLink :: [ContainerId] -> ContainerRequest -> ContainerRequest +setLink newLink req = + req {links = newLink} + +-- | Forwards container logs to the given 'LogConsumer' once ran. +-- +-- @since 0.4.0.0 +withFollowLogs :: LogConsumer -> ContainerRequest -> ContainerRequest +withFollowLogs logConsumer request = + request {followLogs = Just logConsumer} + +-- | Defintion of a 'Port'. Allows for specifying ports using various protocols. Due to the +-- 'Num' and 'IsString' instance allows for convenient Haskell literals. +-- +-- >>> "80" :: Port +-- 80/tcp +-- +-- >>> "80/tcp" :: Port +-- 80/tcp +-- +-- >>> 80 :: Port +-- 80/tcp +-- +-- >>> "90/udp" :: Port +-- 90/udp +data Port = Port + { port :: Int, + protocol :: Text + } + deriving stock (Eq, Ord) + +defaultProtocol :: Text +defaultProtocol = "tcp" + +-- @since 0.4.0.0 +instance Show Port where + show Port {port, protocol} = + show port <> "/" <> unpack protocol + +-- | A cursed but handy instance supporting literal 'Port's. +-- +-- @since 0.4.0.0 +instance Num Port where + fromInteger x = + Port {port = fromIntegral x, protocol = defaultProtocol} + (+) = Prelude.error "not implemented" + (*) = Prelude.error "not implemented" + abs = Prelude.error "not implemented" + signum = Prelude.error "not implemented" + negate = Prelude.error "not implemented" + +-- | A cursed but handy instance supporting literal 'Port's of them +-- form @"8080"@, @"8080/udp"@, @"8080/tcp"@. +-- +-- @since 0.4.0.0 +instance IsString Port where + fromString input = case splitOn "/" (pack input) of + [numberish] + | Right (port, "") <- decimal numberish -> + Port {port, protocol = defaultProtocol} + [numberish, protocol] + | Right (port, "") <- decimal numberish -> + Port {port, protocol} + _ -> + Prelude.error ("invalid port literal: " <> input) + +-- | Set exposed ports on the container. This is equivalent to setting @--publish $PORT@ to +-- @docker run@. Docker assigns a random port for the host port. You will have to use `containerIp` +-- and `containerPort` to connect to the published port. +-- +-- @ +-- container <- `run` $ `containerRequest` `redis` & `setExpose` [ 6379 ] +-- let (redisHost, redisPort) = (`containerIp` container, `containerPort` container 6379) +-- print (redisHost, redisPort) +-- @ +-- +-- @since 0.1.0.0 +setExpose :: [Port] -> ContainerRequest -> ContainerRequest +setExpose newExpose req = + req {exposedPorts = newExpose} + +-- | Set the waiting strategy on the container. Depending on a Docker container +-- it can take some time until the provided service is ready. You will want to +-- use to `setWaitingFor` to block until the container is ready to use. +-- +-- @since 0.1.0.0 +setWaitingFor :: WaitUntilReady -> ContainerRequest -> ContainerRequest +setWaitingFor newWaitingFor req = + req {readiness = newWaitingFor} + +-- | Runs a Docker container from an `Image` and `ContainerRequest`. A finalizer +-- is registered so that the container is aways stopped when it goes out of scope. +-- This function is essentially @docker run@. +-- +-- @since 0.1.0.0 +run :: ContainerRequest -> TestContainer Container +run request = do + let ContainerRequest + { toImage, + naming, + cmd, + env, + exposedPorts, + volumeMounts, + network, + networkAlias, + links, + rmOnExit, + readiness, + labels, + noReaper, + followLogs + } = request + + config@Config {configTracer, configCreateReaper} <- + ask + + additionalLabels <- + if noReaper + then do + pure [] + else reaperLabels <$> configCreateReaper + + image@Image {tag} <- runToImage toImage + + name <- + case naming of + RandomName -> return Nothing + FixedName n -> return $ Just n + SuffixedName prefix -> + Just . (prefix <>) . ("-" <>) . pack + <$> replicateM 6 (Random.randomRIO ('a', 'z')) + + let dockerRun :: [Text] + dockerRun = + concat $ + [["run"]] + ++ [["--detach"]] + ++ [["--name", containerName] | Just containerName <- [name]] + ++ [["--label", label <> "=" <> value] | (label, value) <- additionalLabels ++ labels] + ++ [["--env", variable <> "=" <> value] | (variable, value) <- env] + ++ [["--publish", pack (show port) <> "/" <> protocol] | Port {port, protocol} <- exposedPorts] + ++ [["--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] + ++ [["--rm"] | rmOnExit] + ++ [[tag]] + ++ [command | Just command <- [cmd]] + + stdout <- docker configTracer dockerRun + + let id :: ContainerId + !id = + -- N.B. Force to not leak STDOUT String + strip (pack stdout) + + -- Careful, this is really meant to be lazy + ~inspectOutput = + unsafePerformIO $ + internalInspect 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 ()) + + forM_ followLogs $ + dockerFollowLogs configTracer id + + let container = + Container + { id, + releaseKey, + image, + inspectOutput, + config + } + + -- Last but not least, execute the WaitUntilReady checks + waitUntilReady container readiness + + pure container + +-- | Sets up a Ryuk 'Reaper'. +-- +-- @since 0.4.0.0 +createRyukReaper :: TestContainer Reaper +createRyukReaper = do + ryukContainer <- + run $ + containerRequest (fromTag ryukImageTag) + & skipReaper + & setVolumeMounts [("/var/run/docker.sock", "/var/run/docker.sock")] + & setExpose [ryukPort] + & setWaitingFor (waitUntilMappedPortReachable ryukPort) + & setRm True + + (ryukContainerAddress, ryukContainerPort) <- + containerAddress ryukContainer ryukPort + + 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 +kill :: Container -> TestContainer () +kill Container {id} = do + tracer <- askTracer + _ <- docker tracer ["kill", id] + return () + +-- | Stops a Docker container. `stop` is essentially @docker stop@. +-- +-- @since 0.1.0.0 +stop :: Container -> TestContainer () +stop Container {id} = do + tracer <- askTracer + _ <- docker tracer ["stop", id] + return () + +-- | Remove a Docker container. `rm` is essentially @docker rm -f@ +-- +-- @since 0.1.0.0 +rm :: Container -> TestContainer () +rm Container {id} = do + tracer <- askTracer + _ <- docker tracer ["rm", "-f", "-v", id] + return () + +-- | Access STDOUT and STDERR of a running Docker container. This is essentially +-- @docker logs@ under the hood. +-- +-- @since 0.1.0.0 +withLogs :: Container -> (Handle -> Handle -> TestContainer a) -> TestContainer a +withLogs Container {id} logger = do + let acquire :: TestContainer (Handle, Handle, Handle, Process.ProcessHandle) + acquire = + liftIO $ + Process.runInteractiveProcess + "docker" + ["logs", "--follow", unpack id] + Nothing + Nothing + + release :: (Handle, Handle, Handle, Process.ProcessHandle) -> TestContainer () + release (stdin, stdout, stderr, handle) = + liftIO $ + Process.cleanupProcess + (Just stdin, Just stdout, Just stderr, handle) + + bracket acquire release $ \(stdin, stdout, stderr, _handle) -> do + -- No need to keep it around... + liftIO $ hClose stdin + logger stdout stderr + +-- | A tag to a Docker image. +-- +-- @since 0.1.0.0 +type ImageTag = Text + +-- | A description of how to build an `Image`. +-- +-- @since 0.1.0.0 +data ToImage = ToImage + { runToImage :: TestContainer Image + } + +-- | Build the `Image` referred to by the argument. If the construction of the +-- image is expensive (e.g. a call to `fromBuildContext`) we don't want to +-- repeatedly build the image. Instead, `build` can be used to execute the +-- underlying Docker build once and re-use the resulting `Image`. +-- +-- @since 0.1.0.0 +build :: ToImage -> TestContainer ToImage +build toImage = do + image <- runToImage toImage + return $ + toImage + { runToImage = pure image + } + +-- | Default `ToImage`. Doesn't apply anything to to `ContainerRequests`. +-- +-- @since 0.1.0.0 +defaultToImage :: TestContainer Image -> ToImage +defaultToImage action = + ToImage + { runToImage = action + } + +-- | Get an `Image` from a tag. +-- +-- @since 0.1.0.0 +fromTag :: ImageTag -> ToImage +fromTag tag = defaultToImage $ do + tracer <- askTracer + output <- docker tracer ["pull", "--quiet", tag] + return $ + Image + { tag = strip (pack output) + } + +-- | Build the image from a build path and an optional path to the +-- Dockerfile (default is Dockerfile) +-- +-- @since 0.1.0.0 +fromBuildContext :: + FilePath -> + Maybe FilePath -> + ToImage +fromBuildContext path mdockerfile = defaultToImage $ do + let args + | Just dockerfile <- mdockerfile = + ["build", "--quiet", "--file", pack dockerfile, pack path] + | otherwise = + ["build", "--quiet", pack path] + tracer <- askTracer + output <- docker tracer args + return $ + Image + { tag = strip (pack output) + } + +-- | Build a contextless image only from a Dockerfile passed as `Text`. +-- +-- @since 0.1.0.0 +fromDockerfile :: + Text -> + ToImage +fromDockerfile dockerfile = defaultToImage $ do + tracer <- askTracer + output <- dockerWithStdin tracer ["build", "--quiet", "-"] dockerfile + return $ + Image + { tag = strip (pack output) + } + +-- | A strategy that describes how to asses readiness of a `Container`. Allows +-- Users to plug in their definition of readiness. +-- +-- @since 0.1.0.0 +data WaitUntilReady + = -- | A blocking action that attests readiness + WaitReady + -- Check to run + (Container -> TestContainer ()) + | -- | In order to keep readiness checking at bay this node + -- ensures checks are not exceeding their time share + WaitUntilTimeout + -- Timeout in seconds + Int + -- Action to watch with with timeout + WaitUntilReady + | WaitMany + -- First check + WaitUntilReady + -- Next check + WaitUntilReady + +-- | @since 0.4.0.0 +instance Semigroup WaitUntilReady where + (<>) = WaitMany + +-- | @since 0.4.0.0 +instance Monoid WaitUntilReady where + mempty = WaitReady mempty + +-- | The exception thrown by `waitForLine` in case the expected log line +-- wasn't found. +-- +-- @since 0.1.0.0 +newtype UnexpectedEndOfPipe = UnexpectedEndOfPipe + { -- | The id of the underlying container. + id :: ContainerId + } + deriving (Eq, Show) + +instance Exception UnexpectedEndOfPipe + +-- | The exception thrown by `waitUntilTimeout`. +-- +-- @since 0.1.0.0 +newtype TimeoutException = TimeoutException + { -- | The id of the underlying container that was not ready in time. + id :: ContainerId + } + deriving (Eq, Show) + +instance Exception TimeoutException + +-- | The exception thrown by `waitForState`. +-- +-- @since 0.1.0.0 +newtype InvalidStateException = InvalidStateException + { -- | The id of the underlying container that was not ready in time. + id :: ContainerId + } + deriving stock (Eq, Show) + +instance Exception InvalidStateException + +-- | @waitForState@ waits for a certain state of the container. If the container reaches a terminal +-- state 'InvalidStateException' will be thrown. +-- +-- @since 0.4.0.0 +waitForState :: (State -> Bool) -> WaitUntilReady +waitForState isReady = WaitReady $ \Container {id} -> do + let wait = do + Config {configTracer} <- + ask + inspectOutput <- + internalInspect configTracer id + + let state = containerState inspectOutput + + if isReady state + then pure () + else do + case stateStatus state of + Exited -> + -- Once exited, state won't change! + throwM InvalidStateException {id} + Dead -> + -- Once dead, state won't change! + throwM InvalidStateException {id} + _ -> do + liftIO (threadDelay 500000) + wait + wait + +-- | @successfulExit@ is supposed to be used in conjunction with 'waitForState'. +-- +-- @since 0.4.0.0 +successfulExit :: State -> Bool +successfulExit state = + stateStatus state == Exited && stateExitCode state == Just 0 + +-- | @waitUntilTimeout n waitUntilReady@ waits @n@ seconds for the container +-- to be ready. If the container is not ready by then a `TimeoutException` will +-- be thrown. +-- +-- @since 0.1.0.0 +waitUntilTimeout :: Int -> WaitUntilReady -> WaitUntilReady +waitUntilTimeout = WaitUntilTimeout + +-- | Waits for a specific http status code. +-- This combinator should always be used with `waitUntilTimeout`. +-- +-- @since 0.4.0.0 +waitForHttp :: + -- | Port + Port -> + -- | URL path + String -> + -- | Acceptable status codes + [Int] -> + WaitUntilReady +waitForHttp port path acceptableStatusCodes = WaitReady $ \container -> do + Config {configTracer} <- ask + let wait :: (MonadIO m, MonadCatch m) => m () + wait = + liftIO (newManager defaultManagerSettings) >>= retry + + retry :: (MonadIO m, MonadCatch m) => Manager -> m () + retry manager = do + (endpointHost, endpointPort) <- containerAddress container port + let request = + defaultRequest + { host = encodeUtf8 endpointHost, + port = endpointPort, + path = encodeUtf8 (pack path) + } + result <- + try $ + statusCode . responseStatus <$> liftIO (httpNoBody request manager) + case result of + Right code -> do + withTrace + configTracer + (TraceHttpCall endpointHost endpointPort (Right code)) + unless (code `elem` acceptableStatusCodes) $ + retry manager + Left (exception :: HttpException) -> do + withTrace + configTracer + (TraceHttpCall endpointHost endpointPort (Left $ show exception)) + liftIO (threadDelay 500000) + retry manager + + wait + +-- | Waits until the port of a container is ready to accept connections. +-- This combinator should always be used with `waitUntilTimeout`. +-- +-- @since 0.1.0.0 +waitUntilMappedPortReachable :: + Port -> + WaitUntilReady +waitUntilMappedPortReachable port = WaitReady $ \container -> do + withFrozenCallStack $ do + Config {configTracer} <- ask + + let resolve endpointHost endpointPort = do + let hints = Socket.defaultHints {Socket.addrSocketType = Socket.Stream} + head <$> Socket.getAddrInfo (Just hints) (Just endpointHost) (Just (show endpointPort)) + + open addr = do + socket <- + Socket.socket + (Socket.addrFamily addr) + (Socket.addrSocketType addr) + (Socket.addrProtocol addr) + Socket.connect + socket + (Socket.addrAddress addr) + pure socket + + wait = do + (endpointHost, endpointPort) <- containerAddress container port + + result <- try (resolve (unpack endpointHost) endpointPort >>= open) + case result of + Right socket -> do + withTrace configTracer (TraceOpenSocket endpointHost endpointPort Nothing) + Socket.close socket + pure () + Left (exception :: IOException) -> do + withTrace + configTracer + (TraceOpenSocket endpointHost endpointPort (Just exception)) + threadDelay 500000 + wait + + liftIO wait + +-- | A low-level primitive that allows scanning the logs for specific log lines +-- that indicate readiness of a container. +-- +-- The `Handle`s passed to the function argument represent @stdout@ and @stderr@ +-- of the container. +-- +-- @since 0.1.0.0 +waitWithLogs :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady +waitWithLogs waiter = WaitReady $ \container -> + withLogs container $ \stdout stderr -> + liftIO $ waiter container stdout stderr + +-- | Waits for a specific line to occur in the logs. Throws a `UnexpectedEndOfPipe` +-- exception in case the desired line can not be found on the logs. +-- +-- Say you want to find "Ready to accept connections" in the logs on Stdout try: +-- +-- @ +-- waitForLogLine Stdout ("Ready to accept connections" ``LazyText.isInfixOf``) +-- @ +-- +-- @since 0.1.0.0 +waitForLogLine :: Pipe -> (LazyText.Text -> Bool) -> WaitUntilReady +waitForLogLine whereToLook matches = waitWithLogs $ \Container {id} stdout stderr -> do + let logs :: Handle + logs = case whereToLook of + Stdout -> stdout + Stderr -> stderr + + logContent <- LazyByteString.hGetContents logs + + let logLines :: [LazyText.Text] + logLines = + -- FIXME: This is assuming UTF8 encoding. Do better! + map + (LazyText.decodeUtf8With lenientDecode) + (LazyByteString.lines logContent) + + case find matches logLines of + Just _ -> pure () + Nothing -> throwM $ UnexpectedEndOfPipe {id} + +-- | Blocks until the container is ready. `waitUntilReady` might throw exceptions +-- depending on the used `WaitUntilReady` on the container. +-- +-- In case the readiness check times out 'waitUntilReady' throws a +-- 'TimeoutException'. +-- +-- @since 0.1.0.0 +waitUntilReady :: Container -> WaitUntilReady -> TestContainer () +waitUntilReady container@Container {id} input = do + Config {configDefaultWaitTimeout} <- ask + interpreter $ case configDefaultWaitTimeout of + Just seconds -> waitUntilTimeout seconds input + Nothing -> input + where + interpreter :: WaitUntilReady -> TestContainer () + interpreter wait = + case wait of + WaitReady check -> + check container + WaitUntilTimeout seconds rest -> + withRunInIO $ \runInIO -> do + result <- + timeout (seconds * 1000000) $ + runInIO (interpreter rest) + case result of + Nothing -> + throwM $ TimeoutException {id} + Just {} -> + pure () + WaitMany first second -> do + interpreter first + interpreter second + +-- | Handle to a Docker image. +-- +-- @since 0.1.0.0 +data Image = Image + { -- | The image tag assigned by Docker. Uniquely identifies an `Image` + -- within Docker. + tag :: ImageTag + } + deriving (Eq, Show) + +-- | The image tag assigned by Docker. Uniquely identifies an `Image` +-- within Docker. +-- +-- @since 0.1.0.0 +imageTag :: Image -> ImageTag +imageTag Image {tag} = tag + +-- | Handle to a Docker container. +-- +-- @since 0.1.0.0 +data Container = Container + { -- | The container Id assigned by Docker, uniquely identifying this `Container`. + id :: ContainerId, + -- | Underlying `ReleaseKey` for the resource finalizer. + releaseKey :: ReleaseKey, + -- | The underlying `Image` of this container. + image :: Image, + -- | Configuration used to create and run this container. + config :: Config, + -- | Memoized output of `docker inspect`. This is being calculated lazily. + inspectOutput :: InspectOutput + } + +-- | Returns the id of the container. +-- +-- @since 0.1.0.0 +containerId :: Container -> ContainerId +containerId Container {id} = id + +-- | Returns the underlying image of the container. +-- +-- @since 0.1.0.0 +containerImage :: Container -> Image +containerImage Container {image} = image + +-- | Returns the internal release key used for safely shutting down +-- the container. Use this with care. This function is considered +-- an internal detail. +-- +-- @since 0.1.0.0 +containerReleaseKey :: Container -> ReleaseKey +containerReleaseKey Container {releaseKey} = releaseKey +{-# DEPRECATED containerReleaseKey "Containers are cleaned up with a separate resource reaper. Releasing the container manually is not going to work." #-} + +-- | Looks up the ip address of the container. +-- +-- @since 0.1.0.0 +containerIp :: Container -> Text +containerIp = + internalContainerIp + +-- | Get the IP address of a running Docker container using @docker inspect@. +internalContainerIp :: Container -> Text +internalContainerIp Container {id, inspectOutput} = + case inspectOutput + ^? Optics.key "NetworkSettings" + % Optics.key "IPAddress" + % Optics._String of + Nothing -> + throw $ InspectOutputUnexpected {id} + Just address -> + address + +-- | Get the container's network alias. +-- Takes the first alias found. +-- +-- @since 0.4.0.0 +containerAlias :: Container -> Text +containerAlias Container {id, inspectOutput} = + case inspectOutput + ^? pre + ( Optics.key "NetworkSettings" + % Optics.key "Networks" + % Optics.members + % Optics.key "Aliases" + % Optics.values + % Optics._String + ) of + Nothing -> + throw $ + InspectOutputMissingNetwork + { id + } + Just alias -> + alias + +-- | Get the IP address for the container's gateway, i.e. the host. +-- Takes the first gateway address found. +-- +-- @since 0.4.0.0 +containerGateway :: Container -> Text +containerGateway Container {id, inspectOutput} = + case inspectOutput + ^? pre + ( Optics.key "NetworkSettings" + % Optics.key "Networks" + % Optics.members + % Optics.key "Gateway" + % Optics._String + ) of + Nothing -> + throw $ + InspectOutputMissingNetwork + { id + } + Just gatewayIp -> + gatewayIp + +-- | Looks up an exposed port on the host. +-- +-- @since 0.1.0.0 +containerPort :: Container -> Port -> Int +containerPort Container {id, inspectOutput} 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 + textPort = fromString $ show port <> "/" <> unpack protocol + in -- TODO be more mindful, make sure to grab the + -- port from the right host address + + case inspectOutput + ^? pre + ( Optics.key "NetworkSettings" + % Optics.key "Ports" + % Optics.key textPort + % Optics.values + % Optics.key "HostPort" + % Optics._String + ) of + Nothing -> + throw $ + UnknownPortMapping + { id, + port = textPort + } + Just hostPort -> + read (unpack hostPort) + +-- | Returns the domain and port exposing the given container's port. Differs +-- from 'containerPort' in that 'containerAddress' will return the container's +-- domain and port if the program is running in the same network. Otherwise, +-- 'containerAddress' will use the exposed port on the Docker host. +-- +-- @since 0.4.0.0 +containerAddress :: (MonadIO m) => Container -> Port -> m (Text, Int) +containerAddress container Port {port, protocol} = do + inDocker <- isRunningInDocker + pure $ + if inDocker + then (containerAlias container, port) + else ("localhost", containerPort container (Port {port, protocol})) + +-- | Runs the `docker inspect` command. Memoizes the result. +-- +-- @since 0.1.0.0 +inspect :: Container -> TestContainer InspectOutput +inspect Container {inspectOutput} = + pure inspectOutput + +-- | Runs the `docker inspect` command. +-- +-- @since 0.1.0.0 +internalInspect :: (MonadThrow m, MonadIO m) => Tracer -> ContainerId -> m InspectOutput +internalInspect tracer id = do + stdout <- docker tracer ["inspect", id] + case decode' (LazyByteString.pack stdout) of + Nothing -> + throwM $ InspectOutputInvalidJSON {id} + Just [] -> + throwM $ InspectUnknownContainerId {id} + Just [value] -> + pure value + Just _ -> + Prelude.error "Internal: Multiple results where I expected single result" + +askTracer :: (MonadReader Config m) => m Tracer +askTracer = do + Config {configTracer} <- ask + pure configTracer +{-# INLINE askTracer #-} + +dockerHostOs :: TestContainer Text +dockerHostOs = do + tracer <- askTracer + strip . pack <$> docker tracer ["version", "--format", "{{.Server.Os}}"] + +isDockerOnLinux :: TestContainer Bool +isDockerOnLinux = + ("linux" ==) <$> dockerHostOs + +-- | Detects if we are actually running in a Docker container. +isRunningInDocker :: (MonadIO m) => m Bool +isRunningInDocker = liftIO $ doesFileExist "/.dockerenv" diff --git a/src/TestContainers/Docker.hs-boot b/src/TestContainers/Docker.hs-boot new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker.hs-boot @@ -0,0 +1,9 @@ +module TestContainers.Docker + ( createRyukReaper, + ) +where + +import TestContainers.Docker.Reaper (Reaper) +import TestContainers.Monad (TestContainer) + +createRyukReaper :: TestContainer Reaper diff --git a/src/TestContainers/Docker/Internal.hs b/src/TestContainers/Docker/Internal.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker/Internal.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestContainers.Docker.Internal + ( DockerException (..), + + -- * Container related stuff + ContainerId, + InspectOutput, + + -- * Network related stuff + NetworkId, + + -- * Running docker + docker, + dockerWithStdin, + + -- * Following logs + Pipe (..), + LogConsumer, + consoleLogConsumer, + dockerFollowLogs, + ) +where + +import qualified Control.Concurrent.Async as Async +import Control.Exception (Exception) +import Control.Monad (forever) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.Aeson (Value) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Foldable (traverse_) +import Data.Text (Text, pack, unpack) +import System.Exit (ExitCode (..)) +import qualified System.IO +import qualified System.Process as Process +import TestContainers.Trace (Trace (..), Tracer, withTrace) + +-- | Identifies a network within the Docker runtime. Assigned by @docker network create@ +-- +-- @since 0.4.0.0 +type NetworkId = Text + +-- | Identifies a container within the Docker runtime. Assigned by @docker run@. +-- +-- @since 0.1.0.0 +type ContainerId = Text + +-- | The parsed JSON output of docker inspect command. +-- +-- @since 0.1.0.0 +type InspectOutput = Value + +-- | Failing to interact with Docker results in this exception +-- being thrown. +-- +-- @since 0.1.0.0 +data DockerException + = DockerException + { -- | Exit code of the underlying Docker process. + exitCode :: ExitCode, + -- | Arguments that were passed to Docker. + args :: [Text], + -- | Docker's STDERR output. + stderr :: Text + } + | InspectUnknownContainerId {id :: ContainerId} + | InspectOutputInvalidJSON {id :: ContainerId} + | InspectOutputMissingNetwork {id :: ContainerId} + | InspectOutputUnexpected {id :: ContainerId} + | 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 + } + deriving (Eq, Show) + +instance Exception DockerException + +-- | Internal function that runs Docker. Takes care of throwing an exception +-- in case of failure. +-- +-- @since 0.1.0.0 +docker :: (MonadIO m) => Tracer -> [Text] -> m String +docker tracer args = + dockerWithStdin tracer args "" + +-- | Internal function that runs Docker. Takes care of throwing an exception +-- in case of failure. +-- +-- @since 0.1.0.0 +dockerWithStdin :: (MonadIO m) => Tracer -> [Text] -> Text -> m String +dockerWithStdin tracer args stdin = liftIO $ do + (exitCode, stdout, stderr) <- + Process.readProcessWithExitCode + "docker" + (map unpack args) + (unpack stdin) + + withTrace tracer (TraceDockerInvocation args stdin exitCode) + + -- TODO output these concurrently with the process + traverse_ (withTrace tracer . TraceDockerStdout . pack) (lines stdout) + traverse_ (withTrace tracer . TraceDockerStderr . pack) (lines stderr) + + case exitCode of + ExitSuccess -> pure stdout + _ -> + throwM $ + DockerException + { exitCode, + args, + stderr = pack stderr + } + +-- | A data type indicating which pipe to scan for a specific log line. +-- +-- @since 0.1.0.0 +data Pipe + = -- | Refer to logs on STDOUT. + Stdout + | -- | Refer to logs on STDERR. + Stderr + deriving stock (Eq, Ord, Show) + +-- | An abstraction for forwarding logs. +-- +-- @since 0.4.0.0 +type LogConsumer = Pipe -> ByteString -> IO () + +-- | A simple 'LogConsumer' that writes log lines to stdout and stderr respectively. +-- +-- @since 0.4.0.0 +consoleLogConsumer :: LogConsumer +consoleLogConsumer pipe line = do + case pipe of + Stdout -> do + ByteString.hPutStr System.IO.stdout line + ByteString.hPut System.IO.stdout (ByteString.singleton 0x0a) + Stderr -> do + ByteString.hPutStr System.IO.stderr line + ByteString.hPut System.IO.stderr (ByteString.singleton 0x0a) + +-- | Forwards container logs to a 'LogConsumer'. This is equivalent of calling @docker logs containerId --follow@ +-- +-- @since 0.4.0.0 +dockerFollowLogs :: (MonadResource m) => Tracer -> ContainerId -> LogConsumer -> m () +dockerFollowLogs tracer containerId logConsumer = do + let dockerArgs = + ["logs", containerId, "--follow"] + + (_releaseKey, _result) <- + allocate + ( do + process@(_stdin, Just stdout, Just stderr, _processHandle) <- + Process.createProcess $ + (Process.proc "docker" (map unpack dockerArgs)) + { Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe + } + + withTrace tracer (TraceDockerFollowLogs dockerArgs) + + stdoutReporter <- Async.async $ do + forever $ do + line <- ByteString.hGetLine stdout + logConsumer Stdout line + + stderrReporter <- Async.async $ do + forever $ do + line <- ByteString.hGetLine stderr + logConsumer Stderr line + + pure (process, stdoutReporter, stderrReporter) + ) + ( \(process, stdoutReporter, stderrReporter) -> do + Async.cancel stdoutReporter + Async.cancel stderrReporter + Process.cleanupProcess process + ) + + pure () diff --git a/src/TestContainers/Docker/Network.hs b/src/TestContainers/Docker/Network.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker/Network.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module TestContainers.Docker.Network + ( -- * Network + NetworkId, + Network, + networkId, + + -- * Creating networks + createNetwork, + NetworkRequest, + networkRequest, + withDriver, + withIpv6, + ) +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.Reaper (reaperLabels) +import TestContainers.Monad (Config (..), TestContainer) +import Prelude hiding (id) + +-- | Handle to a Docker network. +-- +-- @since 0.4.0.0 +newtype Network = Network + { id :: NetworkId + } + +-- | Returns the id of the network. +-- +-- @since 0.4.0.0 +networkId :: Network -> NetworkId +networkId Network {id} = id + +-- | Parameters for creating a new Docker network. +-- +-- @since 0.4.0.0 +data NetworkRequest = NetworkRequest + { ipv6 :: Bool, + driver :: Maybe Text, + labels :: [(Text, Text)] + } + +-- | Default parameters for creating a new Docker network. +-- +-- @since 0.4.0.0 +networkRequest :: NetworkRequest +networkRequest = + NetworkRequest + { ipv6 = False, + driver = Nothing, + labels = [] + } + +-- | Enable IPv6 for the Docker network. +-- +-- @since 0.4.0.0 +withIpv6 :: NetworkRequest -> NetworkRequest +withIpv6 request = + request {ipv6 = True} + +-- | Driver to manage the Network (default "bridge"). +-- +-- @since 0.4.0.0 +withDriver :: Text -> NetworkRequest -> NetworkRequest +withDriver driver request = + request {driver = Just driver} + +-- | Creates a new 'Network' from a 'NetworkRequest'. +-- +-- @since 0.4.0.0 +createNetwork :: NetworkRequest -> TestContainer Network +createNetwork NetworkRequest {..} = do + Config {..} <- ask + + name <- + pack <$> replicateM 16 (Random.randomRIO ('a', 'z')) + + reaper <- + configCreateReaper + + -- Creating the network with the reaper labels ensures cleanup + -- at the end of the session + let additionalLabels = + reaperLabels reaper + + stdout <- + docker configTracer $ + concat $ + [["network", "create"]] + ++ [["--driver", driver_] | Just driver_ <- [driver]] + ++ [["--ipv6" | ipv6]] + ++ [["--label", label <> "=" <> value] | (label, value) <- additionalLabels <> labels] + ++ [[name]] + + let id :: NetworkId + !id = + -- N.B. Force to not leak STDOUT String + strip (pack stdout) + + pure Network {..} diff --git a/src/TestContainers/Docker/Reaper.hs b/src/TestContainers/Docker/Reaper.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker/Reaper.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestContainers.Docker.Reaper + ( Reaper, + reaperLabels, + + -- * Ryuk based reaper + ryukImageTag, + ryukPort, + newRyukReaper, + ) +where + +import Control.Monad (replicateM) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (encodeUtf8) +import qualified Network.Socket as Socket +import qualified Network.Socket.ByteString as Socket +import qualified System.Random as Random + +-- | Reaper for safe resource cleanup. +-- +-- @since 0.4.0.0 +data Reaper = Reaper + { -- | @runReaper label value@ reaps Docker any Docker resource with a matching + -- label. + runReaper :: Text -> 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)] + } + +-- | 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. +-- +-- @since 0.4.0.0 +reaperLabels :: Reaper -> [(Text, Text)] +reaperLabels Reaper {labels} = + labels + +-- | Ryuk based resource reaper +-- +-- @since 0.4.0.0 +newtype Ryuk = Ryuk {ryukSocket :: Socket.Socket} + +-- | Tag for the ryuk image +-- +-- @since 0.4.0.0 +ryukImageTag :: Text +ryukImageTag = + "docker.io/testcontainers/ryuk:0.3.4" + +-- | Exposed port for the ryuk reaper. +-- +-- @since 0.4.0.0 +ryukPort :: (Num a) => a +ryukPort = + 8080 + +-- | Creates a new 'Reaper' from a host and port. +-- +-- @since 0.4.0.0 +newRyukReaper :: + (MonadResource m) => + -- | Host + Text -> + -- | Port + Int -> + m Reaper +newRyukReaper host port = do + sessionId <- + pack <$> replicateM 16 (Random.randomRIO ('a', 'z')) + + (_releaseKey, (_socket, ryuk)) <- + allocate + ( do + let hints = + Socket.defaultHints {Socket.addrSocketType = Socket.Stream} + address <- + head <$> Socket.getAddrInfo (Just hints) (Just (unpack host)) (Just (show port)) + socket <- + Socket.openSocket address + Socket.connect socket (Socket.addrAddress address) + pure (socket, runRyuk sessionId (Ryuk socket)) + ) + ( \(socket, ryuk) -> do + runReaper ryuk sessionIdLabel sessionId + Socket.close socket + ) + + pure ryuk + +runRyuk :: + -- | Session id + Text -> + Ryuk -> + Reaper +runRyuk sessionId ryuk = + Reaper + { runReaper = \label value -> do + Socket.sendAll + (ryukSocket ryuk) + ("label=" <> encodeUtf8 label <> "=" <> encodeUtf8 value <> "\n") + _ <- Socket.recv (ryukSocket ryuk) 2 + pure (), + labels = + [ (sessionIdLabel, sessionId) + ] + } + +sessionIdLabel :: Text +sessionIdLabel = "org.testcontainers.haskell.session" diff --git a/src/TestContainers/Docker/State.hs b/src/TestContainers/Docker/State.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Docker/State.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module TestContainers.Docker.State + ( State, + containerState, + + -- * Container status + Status (..), + stateStatus, + stateOOMKilled, + statePid, + stateExitCode, + stateError, + stateStartedAt, + stateFinishedAt, + ) +where + +import Control.Exception (Exception, throw) +import Data.Aeson (Value) +import qualified Data.Aeson.Optics as Optics +import Data.Text (Text) +import Optics.Operators ((^?)) +import Optics.Optic ((%)) +import TestContainers.Docker.Internal (InspectOutput) + +-- | An exception thrown in case the State object is invalid and couldn't be parsed. +-- +-- @since 0.4.0.0 +data StateInvalidException = StateInvalidException + deriving stock (Eq, Show) + +instance Exception StateInvalidException + +-- | Status of a Docker container. +-- +-- @since 0.4.0.0 +data Status + = Created + | Running + | Paused + | Restarting + | Removing + | Exited + | Dead + | Other Text + deriving (Eq, Show) + +-- | State of a Docker container. +-- +-- @since 0.4.0.0 +newtype State = State Value + +-- | Extract the 'State' of a Docker container from an 'InspectOutput'. +-- +-- @since 0.4.0.0 +containerState :: InspectOutput -> State +containerState inspectOutput = + case inspectOutput ^? Optics.key "State" of + Just state -> State state + Nothing -> State "dummy" + +-- | Returns the 'Status' of container. +-- +-- @since 0.4.0.0 +stateStatus :: State -> Status +stateStatus (State value) = + case value + ^? Optics.key "Status" + % Optics._String of + Just "created" -> Created + Just "running" -> Running + Just "paused" -> Paused + Just "restarting" -> Restarting + Just "removing" -> Removing + Just "exited" -> Exited + Just "dead" -> Dead + Just other -> Other other + Nothing -> throw StateInvalidException + +-- | Whether a container was killed by the OOM killer. +-- +-- @since 0.4.0.0 +stateOOMKilled :: State -> Bool +stateOOMKilled (State value) = + case value + ^? Optics.key "OOMKilled" + % Optics._Bool of + Just True -> True + _ -> False + +-- | +-- +-- @since 0.4.0.0 +statePid :: State -> Maybe Int +statePid (State value) = + case value + ^? Optics.key "Pid" + % Optics._Integer of + Just pid -> Just (fromIntegral pid) + _ -> Nothing + +-- | +-- +-- @since 0.4.0.0 +stateExitCode :: State -> Maybe Int +stateExitCode (State value) = + case value + ^? Optics.key "ExitCode" + % Optics._Integer of + Just exitCode -> Just (fromIntegral exitCode) + _ -> Nothing + +-- | +-- +-- @since 0.4.0.0 +stateError :: State -> Maybe Text +stateError (State value) = + case value + ^? Optics.key "Error" + % Optics._String of + Just err -> Just err + _ -> Nothing + +-- | +-- +-- @since 0.4.0.0 +stateStartedAt :: State -> Maybe Text +stateStartedAt (State value) = + case value + ^? Optics.key "StartedAt" + % Optics._String of + Just err -> Just err + _ -> Nothing + +-- | +-- +-- @since 0.4.0.0 +stateFinishedAt :: State -> Maybe Text +stateFinishedAt (State value) = + case value + ^? Optics.key "FinishedAt" + % 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 @@ -1,26 +1,30 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} + module TestContainers.Hspec - ( - -- * Running containers for tests - withContainers + ( -- * Running containers for tests + withContainers, -- * Re-exports for convenience - , module Reexports - ) where - -import Control.Exception (bracket) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (runReaderT) -import Control.Monad.Trans.Resource (InternalState, - getInternalState) -import Control.Monad.Trans.Resource.Internal (stateAlloc, - stateCleanup) -import Data.Acquire (ReleaseType (ReleaseNormal)) - -import TestContainers as Reexports + module Reexports, + ) +where +import Control.Exception (bracket) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource + ( InternalState, + getInternalState, + liftResourceT, + ) +import Control.Monad.Trans.Resource.Internal + ( stateAlloc, + stateCleanup, + ) +import Data.Acquire (ReleaseType (ReleaseNormal)) +import TestContainers as Reexports +import TestContainers.Monad (runTestContainer) -- | Allow `Hspec.Spec` to depend on Docker containers. Hspec takes care of -- initialization and de-initialization of the containers. @@ -41,24 +45,24 @@ -- @ -- -- `withContainers` allows you naturally scope the handling of containers for your tests. -withContainers - :: forall a - . (forall m. MonadDocker m => m a) - -> (a -> IO ()) - -> IO () +withContainers :: + forall a. + TestContainer a -> + (a -> IO ()) -> + IO () withContainers startContainers = dropState $ bracket acquire release where runC action = do config <- determineConfig - runReaderT (runResourceT action) config + runTestContainer config action acquire :: IO (a, InternalState) acquire = runC $ do - result <- startContainers - releaseMap <- getInternalState + result <- startContainers + releaseMap <- liftResourceT getInternalState - liftIO $ stateAlloc releaseMap - pure (result, releaseMap) + liftIO $ stateAlloc releaseMap + pure (result, releaseMap) release :: (a, InternalState) -> IO () release (_, internalState) = diff --git a/src/TestContainers/Image.hs b/src/TestContainers/Image.hs --- a/src/TestContainers/Image.hs +++ b/src/TestContainers/Image.hs @@ -1,20 +1,23 @@ {-# LANGUAGE OverloadedStrings #-} -module TestContainers.Image - ( - -- * Collection of pre-defined Docker images - redis - , mongo +module TestContainers.Image + ( -- * Collection of pre-defined Docker images + redis, + mongo, -- * Building and managing images - , module Docker - - ) where - -import TestContainers.Docker as Docker (Image, ToImage, build, - fromBuildContext, - fromDockerfile, fromTag) + module Docker, + ) +where +import TestContainers.Docker as Docker + ( Image, + ToImage, + build, + fromBuildContext, + fromDockerfile, + fromTag, + ) -- | Image for Redis database. -- @@ -23,12 +26,10 @@ -- @ -- -- @since 0.1.0.0 --- redis :: ToImage redis = fromTag "redis:5.0" - -- | Image for Mongo database. -- -- @ @@ -36,7 +37,6 @@ -- @ -- -- @since 0.1.0.0 --- mongo :: ToImage mongo = fromTag "mongo:4.0.17" diff --git a/src/TestContainers/Monad.hs b/src/TestContainers/Monad.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Monad.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module TestContainers.Monad + ( -- * Monad + MonadDocker, + TestContainer, + runTestContainer, + + -- * Runtime configuration + Config (..), + ) +where + +import Control.Applicative (liftA2) +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.Reader (MonadReader (..), ReaderT, runReaderT) +import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) +import Data.IORef (newIORef, readIORef, writeIORef) +import TestContainers.Docker.Reaper (Reaper) +import TestContainers.Trace (Tracer) + +newtype TestContainerEnv = TestContainerEnv + { config :: Config + } + +-- | The heart and soul of the testcontainers library. +-- +-- @since 0.4.0.0 +newtype TestContainer a = TestContainer {unTestContainer :: ReaderT TestContainerEnv (ResourceT IO) a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadMask, + MonadCatch, + MonadThrow, + MonadResource, + MonadFix + ) + +-- Instance defined without newtype deriving as GHC has a hard time +-- deriving it for old versions of unliftio. +instance MonadUnliftIO TestContainer where + withRunInIO action = TestContainer $ + withRunInIO $ \runInIo -> + action (runInIo . unTestContainer) + +instance MonadReader Config TestContainer where + ask = TestContainer $ do + TestContainerEnv {config} <- ask + pure config + + local f (TestContainer action) = TestContainer $ do + local (\env@TestContainerEnv {config} -> env {config = f config}) action + +instance (Semigroup a) => Semigroup (TestContainer a) where + (<>) = + liftA2 (<>) + +instance (Monoid a) => Monoid (TestContainer a) where + mempty = pure mempty + +-- | Run a 'TestContainer' action. Any container spun up during the computation are guaranteed +-- to be shutdown and cleaned up once this function returns. +-- +-- @since 0.4.0.0 +runTestContainer :: Config -> TestContainer a -> IO a +runTestContainer config action = do + -- Ensure through caching that there is only ever exactly + -- one 'Reaper' per session. + reaperRef <- newIORef Nothing + let getOrCreateReaper = do + mreaper <- liftIO (readIORef reaperRef) + case mreaper of + Just reaper -> + pure reaper + Nothing -> do + reaper <- configCreateReaper config + liftIO (writeIORef reaperRef (Just reaper)) + pure reaper + + runResourceT + ( runReaderT + (unTestContainer action) + ( TestContainerEnv + { config = + config + { configCreateReaper = getOrCreateReaper + } + } + ) + ) + +-- | Docker related functionality is parameterized over this `Monad`. Since 0.4.0.0 this is +-- just a type alias for @m ~ 'TestContainer'@. +-- +-- @since 0.1.0.0 +type MonadDocker m = + (m ~ TestContainer) + +-- | Configuration for defaulting behavior. +-- +-- @since 0.2.0.0 +data Config = Config + { -- | The number of seconds to maximally wait for a container to + -- become ready. Default is `Just 60`. + -- + -- @Nothing@ <=> waits indefinitely. + configDefaultWaitTimeout :: Maybe Int, + -- | Traces execution inside testcontainers library. + configTracer :: Tracer, + -- | How to obtain a 'Reaper' + configCreateReaper :: TestContainer Reaper + } diff --git a/src/TestContainers/Tasty.hs b/src/TestContainers/Tasty.hs --- a/src/TestContainers/Tasty.hs +++ b/src/TestContainers/Tasty.hs @@ -1,44 +1,53 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} + module TestContainers.Tasty - ( - -- * Tasty Ingredient - ingredient + ( -- * Tasty Ingredient + ingredient, -- * Running containers for tests - , withContainers + withContainers, -- * Re-exports for convenience - , module Reexports - ) where - -import Control.Applicative ((<|>)) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (runReaderT) -import Control.Monad.Trans.Resource (InternalState, - getInternalState) -import Control.Monad.Trans.Resource.Internal (stateAlloc, - stateCleanup) -import Data.Acquire (ReleaseType (ReleaseNormal)) -import Data.Data (Proxy (Proxy)) -import Test.Tasty (TestTree, askOption, - withResource) -import qualified Test.Tasty as Tasty -import Test.Tasty.Ingredients (Ingredient) -import Test.Tasty.Options (IsOption (..), - OptionDescription (..), - mkFlagCLParser, - safeRead) -import TestContainers as Reexports hiding - (Trace) + module Reexports, + ) +where +import Control.Applicative ((<|>)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource + ( InternalState, + getInternalState, + liftResourceT, + ) +import Control.Monad.Trans.Resource.Internal + ( stateAlloc, + stateCleanup, + ) +import Data.Acquire (ReleaseType (ReleaseNormal)) +import Data.Data (Proxy (Proxy)) +import Test.Tasty + ( TestTree, + askOption, + withResource, + ) +import qualified Test.Tasty as Tasty +import Test.Tasty.Ingredients (Ingredient) +import Test.Tasty.Options + ( IsOption (..), + OptionDescription (..), + mkFlagCLParser, + safeRead, + ) +import TestContainers as Reexports hiding + ( Trace, + ) +import TestContainers.Monad (runTestContainer) newtype DefaultTimeout = DefaultTimeout (Maybe Int) - instance IsOption DefaultTimeout where - defaultValue = DefaultTimeout Nothing @@ -51,12 +60,9 @@ optionHelp = pure "The max. number of seconds to wait for a container to become ready" - newtype Trace = Trace Bool - instance IsOption Trace where - defaultValue = Trace False @@ -72,7 +78,6 @@ optionHelp = pure "Turns on tracing of the underlying Docker operations" - -- | Tasty `Ingredient` that adds useful options to control defaults within the -- TetContainers library. -- @@ -82,67 +87,62 @@ -- @ -- -- @since 0.3.0.0 --- ingredient :: Ingredient -ingredient = Tasty.includingOptions - [ - Option (Proxy :: Proxy DefaultTimeout) - , Option (Proxy :: Proxy Trace) - ] - +ingredient = + Tasty.includingOptions + [ Option (Proxy :: Proxy DefaultTimeout), + Option (Proxy :: Proxy Trace) + ] -withContainers - :: forall a - . (forall m. MonadDocker m => m a) - -> (IO a -> TestTree) - -> TestTree +withContainers :: + forall a. + TestContainer a -> + (IO a -> TestTree) -> + TestTree withContainers startContainers tests = - askOption $ \ (DefaultTimeout defaultTimeout) -> - askOption $ \ (Trace enableTrace) -> - let - tracer :: Tracer - tracer - | enableTrace = newTracer $ \message -> - putStrLn (show message) - | otherwise = - mempty + askOption $ \(DefaultTimeout defaultTimeout) -> + askOption $ \(Trace enableTrace) -> + let tracer :: Tracer + tracer + | enableTrace = newTracer $ \message -> + putStrLn (show message) + | otherwise = + mempty - runC action = do - config <- determineConfig + runC action = do + config <- determineConfig - let - actualConfig :: Config - actualConfig = config - { - configDefaultWaitTimeout = - defaultTimeout <|> configDefaultWaitTimeout config - , configTracer = tracer - } + let actualConfig :: Config + actualConfig = + config + { configDefaultWaitTimeout = + defaultTimeout <|> configDefaultWaitTimeout config, + configTracer = tracer + } - runReaderT (runResourceT action) actualConfig + runTestContainer actualConfig action - -- Correct resource handling is tricky here: - -- Tasty offers a bracket alike in IO. We have - -- to transfer the ReleaseMap of the ResIO safely - -- to the release function. Fortunately resourcet - -- let's us access the internal state.. - acquire :: IO (a, InternalState) - acquire = runC $ do - result <- startContainers - releaseMap <- getInternalState + -- Correct resource handling is tricky here: + -- Tasty offers a bracket alike in IO. We have + -- to transfer the ReleaseMap of the ResIO safely + -- to the release function. Fortunately resourcet + -- let's us access the internal state.. + acquire :: IO (a, InternalState) + acquire = runC $ do + result <- startContainers + releaseMap <- liftResourceT getInternalState - -- N.B. runResourceT runs the finalizers on every - -- resource. We don't want it to! We want to run - -- finalization in the release function that is - -- called by Tasty! stateAlloc increments a references - -- count to accomodate for exactly these kind of - -- cases. - liftIO $ stateAlloc releaseMap - pure (result, releaseMap) + -- N.B. runResourceT runs the finalizers on every + -- resource. We don't want it to! We want to run + -- finalization in the release function that is + -- called by Tasty! stateAlloc increments a references + -- count to accomodate for exactly these kind of + -- cases. + liftIO $ stateAlloc releaseMap + pure (result, releaseMap) - release :: (a, InternalState) -> IO () - release (_, internalState) = - stateCleanup ReleaseNormal internalState - in - withResource acquire release $ \mk -> - tests (fmap fst mk) + release :: (a, InternalState) -> IO () + release (_, internalState) = + stateCleanup ReleaseNormal internalState + in withResource acquire release $ \mk -> + tests (fmap fst mk) diff --git a/src/TestContainers/Trace.hs b/src/TestContainers/Trace.hs new file mode 100644 --- /dev/null +++ b/src/TestContainers/Trace.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module TestContainers.Trace + ( -- * TestContainer traces + Trace (..), + + -- * Tracer + Tracer, + newTracer, + withTrace, + ) +where + +import Control.Exception (IOException) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import System.Exit (ExitCode) + +-- | Type representing various events during testcontainer execution. +data Trace + = -- | The low-level invocation of @docker@ command + -- + -- @ + -- TraceDockerInvocation args stdin exitcode + -- @ + TraceDockerInvocation [Text] Text ExitCode -- docker [args] [stdin] + | -- | Preparations to follow the logs for a certain container + TraceDockerFollowLogs [Text] -- docker [args] + | -- | Line written to STDOUT by a Docker process. + TraceDockerStdout Text + | -- | Line written to STDERR by a Docker process. + TraceDockerStderr Text + | -- | Waiting for a container to become ready. Attached with the + -- timeout to wait (in seconds). + TraceWaitUntilReady (Maybe Int) + | -- | Opening socket + TraceOpenSocket Text Int (Maybe IOException) + | -- | Call HTTP endpoint + TraceHttpCall Text Int (Either String Int) + deriving stock (Eq, Show) + +-- | Traces execution within testcontainers library. +newtype Tracer = Tracer {unTracer :: Trace -> IO ()} + deriving newtype (Semigroup, Monoid) + +-- | Construct a new `Tracer` from a tracing function. +newTracer :: + (Trace -> IO ()) -> + Tracer +newTracer action = + Tracer + { unTracer = action + } + +withTrace :: (MonadIO m) => Tracer -> Trace -> m () +withTrace tracer trace = + liftIO $ unTracer tracer trace +{-# INLINE withTrace #-} diff --git a/test/TestContainers/HspecSpec.hs b/test/TestContainers/HspecSpec.hs --- a/test/TestContainers/HspecSpec.hs +++ b/test/TestContainers/HspecSpec.hs @@ -1,23 +1,28 @@ {-# LANGUAGE FlexibleContexts #-} -module TestContainers.HspecSpec(main, spec_all) where -import Test.Hspec -import TestContainers.Hspec (MonadDocker, containerRequest, - redis, run, withContainers) +module TestContainers.HspecSpec (main, spec_all) where +import Test.Hspec +import TestContainers.Hspec + ( TestContainer, + containerRequest, + redis, + run, + withContainers, + ) -containers1 - :: MonadDocker m => m () +containers1 :: + TestContainer () containers1 = do _ <- run $ containerRequest redis pure () - main :: IO () main = hspec spec_all - spec_all :: Spec -spec_all = around (withContainers containers1) $ - describe "TestContainers tests" $ - it "test1" $ shouldBe () +spec_all = + around (withContainers containers1) $ + describe "TestContainers tests" $ + it "test1" $ + shouldBe () diff --git a/test/TestContainers/TastySpec.hs b/test/TestContainers/TastySpec.hs --- a/test/TestContainers/TastySpec.hs +++ b/test/TestContainers/TastySpec.hs @@ -1,49 +1,107 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module TestContainers.TastySpec(main, test_all) where -import Data.Text.Lazy (isInfixOf) -import Test.Tasty -import Test.Tasty.HUnit -import TestContainers.Tasty (MonadDocker, Pipe (Stdout), - containerRequest, fromBuildContext, fromTag, redis, run, - setExpose, setRm, setWaitingFor, - waitForLogLine, - waitUntilMappedPortReachable, - waitUntilTimeout, withContainers, (&)) +module TestContainers.TastySpec (main, test_all) where +import Data.Text.Lazy (isInfixOf) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit +import TestContainers.Tasty + ( Pipe (Stdout), + TestContainer, + consoleLogConsumer, + containerRequest, + createNetwork, + fromBuildContext, + fromTag, + networkRequest, + redis, + run, + setExpose, + setRm, + setWaitingFor, + successfulExit, + waitForHttp, + waitForLogLine, + waitForState, + waitUntilMappedPortReachable, + waitUntilTimeout, + withContainers, + withFollowLogs, + withNetwork, + (&), + ) -containers1 - :: MonadDocker m => m () +containers1 :: + TestContainer () containers1 = do - _redisContainer <- run $ containerRequest redis - & setExpose [ 6379 ] - & setWaitingFor (waitUntilTimeout 30 $ - waitUntilMappedPortReachable 6379) + net <- + createNetwork networkRequest - _rabbitmq <- run $ containerRequest (fromTag "rabbitmq:3.8.4") - & setRm False - & setWaitingFor (waitForLogLine Stdout (("completed with" `isInfixOf`))) + _redisContainer <- + run $ + containerRequest redis + & setExpose [6379] + & withNetwork net + & setWaitingFor + ( waitUntilTimeout 30 $ + waitUntilMappedPortReachable 6379 + ) + _rabbitmq <- + run $ + containerRequest (fromTag "rabbitmq:3.8.4") + & setRm False + & setExpose [5672] + & withNetwork net + & withFollowLogs consoleLogConsumer + & setWaitingFor + ( waitForLogLine Stdout (("completed with" `isInfixOf`)) + <> waitUntilMappedPortReachable 5672 + ) + + _nginx <- + run $ + containerRequest (fromTag "nginx:1.23.1-alpine") + & setExpose [80] + & withNetwork net + & setWaitingFor + ( waitUntilTimeout 30 $ + waitForHttp 80 "/" [200] + ) + + _jaeger <- + run $ + containerRequest (fromTag "jaegertracing/all-in-one:1.6") + & setExpose ["5775/udp", "6831/udp", "6832/udp", "5778", "16686/tcp"] + & withNetwork net + & setWaitingFor + (waitForHttp "16686/tcp" "/" [200]) + + _helloWorld <- + run $ + containerRequest (fromTag "hello-world:latest") + & setWaitingFor (waitForState successfulExit) + _test <- run $ containerRequest (fromBuildContext "./test/container1" Nothing) pure () - main :: IO () main = defaultMain test_all test_all :: TestTree -test_all = testGroup "TestContainers tests" - [ - withContainers containers1 $ \setup -> - testGroup "Multiple tests" - [ - testCase "test1" $ do - setup - return () - , testCase "test2" $ do - setup - return () - ] - ] +test_all = + testGroup + "TestContainers tests" + [ withContainers containers1 $ \setup -> + testGroup + "Multiple tests" + [ testCase "test1" $ do + setup + return (), + testCase "test2" $ do + setup + return () + ] + ] diff --git a/testcontainers.cabal b/testcontainers.cabal --- a/testcontainers.cabal +++ b/testcontainers.cabal @@ -1,67 +1,91 @@ -cabal-version: >=1.10 -name: testcontainers -version: 0.3.1.0 -synopsis: Docker containers for your integration tests. -description: testcontainers is a Haskell library that provides a friendly API to - run Docker containers. It is designed to create a runtime environment - to use during your integration tests +cabal-version: >=1.10 +name: testcontainers +version: 0.4.0.0 +synopsis: Docker containers for your integration tests. +description: + testcontainers is a Haskell library that provides a friendly API to + run Docker containers. It is designed to create a runtime environment + to use during your integration tests + -- bug-reports: -license: MIT -license-file: LICENSE -author: Alex Biehl -maintainer: alex.biehl@target.com -copyright: 2020 Alex Biehl -category: Development -build-type: Simple -extra-source-files: CHANGELOG.md, - README.md +license: MIT +license-file: LICENSE +author: Alex Biehl +maintainer: alex.biehl@gmail.com +copyright: 2023 Alex Biehl +category: Development +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md +tested-with: + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2 + source-repository head - type: git - location: https://github.com/alexbiehl/testcontainers-hs + type: git + location: https://github.com/testcontainers/testcontainers-hs library - exposed-modules: TestContainers - TestContainers.Docker - TestContainers.Hspec - TestContainers.Image - TestContainers.Tasty + exposed-modules: + TestContainers + TestContainers.Config + TestContainers.Docker + TestContainers.Docker.Internal + TestContainers.Docker.Network + TestContainers.Docker.Reaper + TestContainers.Docker.State + TestContainers.Hspec + TestContainers.Image + TestContainers.Monad + TestContainers.Tasty + TestContainers.Trace -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <5, - aeson >= 1.4.6 && < 1.6 || >= 2.0 && < 2.1, - aeson-optics >= 1.1 && < 1.2, - bytestring >= 0.10.8 && < 0.12, - text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.1, - exceptions >= 0.10.4 && < 0.11, - optics-core >= 0.1 && < 0.5, - process >= 1.6.5 && < 1.7, - network >= 2.8.0 && < 3.2, - mtl >= 2.2.2 && < 2.3, - resourcet >= 1.2.4 && < 1.3, - unliftio-core >= 0.1.0 && < 0.3, - tasty >= 1.0 && < 1.5 + build-depends: + aeson >=1.4.6 && <3 + , aeson-optics >=1.1 && <2 + , async + , base >=4.12 && <5 + , bytestring >=0.10.8 && <0.12 + , directory >=1.3.6 && <2 + , exceptions >=0.10.4 && <0.11 + , http-client >=0.5.14 && <1 + , http-types >=0.12.3 && <1 + , mtl >=2.2.2 && <3 + , network >=2.8.0 && <3.2 + , optics-core >=0.1 && <0.5 + , process >=1.6.5 && <1.7 + , random >=1.2 && <2 + , resourcet >=1.2.4 && <1.4 + , tasty >=1.0 && <1.5 + , text >=1.2.3 && <3 + , unliftio-core >=0.1.0 && <0.3 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall test-suite tests - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall - type: exitcode-stdio-1.0 - main-is: Driver.hs - other-modules: TestContainers.HspecSpec - TestContainers.TastySpec - build-tool-depends: hspec-discover:hspec-discover, - tasty-discover:tasty-discover - build-depends: base, - hspec >= 2.0 && < 3.0, - tasty, - tasty-discover >=4.2.1 && <4.3, - tasty-hunit, - tasty-hspec, - testcontainers, - text + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + TestContainers.HspecSpec + TestContainers.TastySpec + + build-tool-depends: + hspec-discover:hspec-discover, tasty-discover:tasty-discover + + build-depends: + base + , hspec >=2.0 && <3.0 + , tasty + , tasty-discover >=4.2.1 && <4.3 + , tasty-hspec + , tasty-hunit + , testcontainers + , text