testcontainers 0.3.1.0 → 0.4.0.0
raw patch · 17 files changed
+2464/−1369 lines, 17 filesdep +asyncdep +directorydep +http-clientdep ~aesondep ~aeson-opticsdep ~mtl
Dependencies added: async, directory, http-client, http-types, random
Dependency ranges changed: aeson, aeson-optics, mtl, resourcet, text
Files
- CHANGELOG.md +16/−0
- src/TestContainers.hs +100/−77
- src/TestContainers/Config.hs +34/−0
- src/TestContainers/Docker.hs +1233/−1059
- src/TestContainers/Docker.hs-boot +9/−0
- src/TestContainers/Docker/Internal.hs +189/−0
- src/TestContainers/Docker/Network.hs +109/−0
- src/TestContainers/Docker/Reaper.hs +116/−0
- src/TestContainers/Docker/State.hs +146/−0
- src/TestContainers/Hspec.hs +32/−28
- src/TestContainers/Image.hs +15/−15
- src/TestContainers/Monad.hs +129/−0
- src/TestContainers/Tasty.hs +89/−89
- src/TestContainers/Trace.hs +59/−0
- test/TestContainers/HspecSpec.hs +16/−11
- test/TestContainers/TastySpec.hs +92/−34
- testcontainers.cabal +80/−56
CHANGELOG.md view
@@ -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)
src/TestContainers.hs view
@@ -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
+ src/TestContainers/Config.hs view
@@ -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
src/TestContainers/Docker.hs view
@@ -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"
+ src/TestContainers/Docker.hs-boot view
@@ -0,0 +1,9 @@+module TestContainers.Docker+ ( createRyukReaper,+ )+where++import TestContainers.Docker.Reaper (Reaper)+import TestContainers.Monad (TestContainer)++createRyukReaper :: TestContainer Reaper
+ src/TestContainers/Docker/Internal.hs view
@@ -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 ()
+ src/TestContainers/Docker/Network.hs view
@@ -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 {..}
+ src/TestContainers/Docker/Reaper.hs view
@@ -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"
+ src/TestContainers/Docker/State.hs view
@@ -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
src/TestContainers/Hspec.hs view
@@ -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) =
src/TestContainers/Image.hs view
@@ -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"
+ src/TestContainers/Monad.hs view
@@ -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+ }
src/TestContainers/Tasty.hs view
@@ -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)
+ src/TestContainers/Trace.hs view
@@ -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 #-}
test/TestContainers/HspecSpec.hs view
@@ -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 ()
test/TestContainers/TastySpec.hs view
@@ -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 ()+ ]+ ]
testcontainers.cabal view
@@ -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