diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for testcontainer-hs +## 0.2.0.0 -- 2020-08-07 + +* Dependency rework (@blackheaven, https://github.com/alexbiehl/testcontainers-hs/pull/3) + ## 0.1.0.0 -- 2020-08-06 * First version. Released on an unsuspecting world. diff --git a/src/TestContainers.hs b/src/TestContainers.hs --- a/src/TestContainers.hs +++ b/src/TestContainers.hs @@ -1,6 +1,109 @@ +-- | +-- 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 ( - module M + + -- * Docker images + + M.ImageTag + + , M.Image + , M.imageTag + + -- * Referring to Docker images + + , M.ToImage + , M.fromTag + , M.fromBuildContext + , M.build + + -- * @docker run@ parameters + + , M.ContainerRequest + , M.containerRequest + + , M.setName + , M.setCmd + , M.setRm + , M.setEnv + , M.setLink + , M.setExpose + , M.setWaitingFor + + -- * Running Docker containers (@docker run@) + + , M.Container + , M.containerIp + , M.containerPort + , M.containerReleaseKey + , M.containerImage + + , M.run + + -- * Inspecting Docker containers + + , M.InspectOutput + , M.inspect + + -- * Docker container lifecycle + + , M.stop + , M.kill + , M.rm + , M.withLogs + + -- * Readiness checks + + , M.WaitUntilReady + + -- ** Timeout for readiness checks + + , M.waitUntilTimeout + + -- ** Waiting on particular log lines + + , M.Pipe(..) + , M.waitWithLogs + , M.waitForLogLine + + -- ** Wait until connection can be established + + , M.waitUntilMappedPortReachable + + -- * Monad + + , M.MonadDocker + + -- * Configuration + + , Config(..) + , defaultDockerConfig + , dockerForMacConfig + , determineConfig + + -- * Exceptions + + , M.DockerException(..) + , M.TimeoutException(..) + , M.UnexpectedEndOfPipe(..) + + -- * Misc. Docker functions + + , dockerVersion + , isDockerForDesktop + + -- * Predefined Docker images + + , M.redis + , M.mongo + + -- * Reexports + + , ResIO + , runResourceT + , (&) ) where import TestContainers.Docker as M diff --git a/src/TestContainers/Docker.hs b/src/TestContainers/Docker.hs --- a/src/TestContainers/Docker.hs +++ b/src/TestContainers/Docker.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -10,6 +11,13 @@ ( MonadDocker + -- * Configuration + + , Config(..) + , defaultDockerConfig + , dockerForMacConfig + , determineConfig + -- * Docker image , ImageTag @@ -79,6 +87,11 @@ , Pipe(..) , waitForLogLine + -- * Misc. Docker functions + + , dockerVersion + , isDockerForDesktop + -- * Wait until a socket is reachable , waitUntilMappedPortReachable @@ -91,25 +104,30 @@ import Control.Concurrent (threadDelay) import Control.Exception (IOException, throw) -import Control.Lens ((^?)) +import Optics.Operators ((^?)) +import Optics.Optic ((%)) +import Optics.Fold (pre) 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.Lens as Lens +import qualified Data.Aeson.Optics as Optics import qualified Data.ByteString.Lazy.Char8 as LazyByteString import Data.Function ((&)) import Data.List (find) -import Data.Text (Text, pack, strip, unpack) +import Data.Text (Text, isInfixOf, 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 (HasCallStack, withFrozenCallStack) +import GHC.Stack (HasCallStack, + withFrozenCallStack) import qualified Network.Socket as Socket import Prelude hiding (error, id) import qualified Prelude @@ -120,8 +138,65 @@ import System.Timeout (timeout) +-- | Configuration for defaulting behavior. +-- +-- Note that IP address returned by `containerIp` is not reachable when using +-- Docker For Mac (See https://docs.docker.com/docker-for-mac/networking/#per-container-ip-addressing-is-not-possible). +-- +-- If you are targeting Docker For Mac you should use `dockerForMacConfig`, instead +-- use `defaultDockerConfig`. +-- +-- @since 0.2.0.0 +-- +data Config = Config + { + -- | How to retrieve the IP address of a Docker container. + -- There some known limitations around Docker for Mac in that + -- it doesn't support accessing containers by their IP (see `containerIp`). + -- + -- This configuration let's you define how to access the IP. + configContainerIp :: Container -> Text + } + + +-- | Default configuration. +-- +-- @since 0.2.0.0 +-- +defaultDockerConfig :: Config +defaultDockerConfig = Config + { + configContainerIp = internalContainerIp + } + + +-- | A default configuration to use with Docker for Mac installations. It doesn't +-- use a Docker container's IP address to access a container, instead it always uses +-- the loopback interface @0.0.0.0@. +-- +-- @since 0.2.0.0 +-- +dockerForMacConfig :: Config +dockerForMacConfig = defaultDockerConfig + { + configContainerIp = \_ -> "0.0.0.0" + } + + +-- | Autoselect the default configuration depending on wether you use Docker For +-- Mac/Desktop or not. +determineConfig :: IO Config +determineConfig = do + -- TODO We used to be clever here but it turned out that it wouldn't let + -- hosts reach containers. Even on linux! Figure out how to do Docker + -- networking properly. + pure dockerForMacConfig + -- | Failing to interact with Docker results in this exception -- being thrown. +-- +-- @since 0.1.0.0 +-- data DockerException = DockerException { @@ -139,7 +214,7 @@ { -- | Id of the `Container` that we tried to lookup the -- port mapping. - id :: ContainerId + id :: ContainerId -- | Textual representation of port mapping we were -- trying to look up. , port :: Text @@ -151,11 +226,17 @@ -- | 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) + (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 @@ -171,6 +252,9 @@ -- | Default `ContainerRequest`. Used as base for every Docker container. +-- +-- @since 0.1.0.0 +-- containerRequest :: ToImage -> ContainerRequest containerRequest image = ContainerRequest { @@ -186,51 +270,80 @@ } --- | Set the name of a Docker container. +-- | 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. +-- | 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 } --- | Wether to remove the container once exited. +-- | 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. +-- | 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. +-- | 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. --- --- Example: +-- | 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. -- --- @ redis --- `&` `setExpose` [ 6379 ] -- @ +-- 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. +-- | 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 } @@ -238,8 +351,12 @@ -- | 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 = liftResourceT $ do +run request = do let ContainerRequest @@ -279,22 +396,23 @@ -- N.B. Force to not leak STDOUT String strip (pack stdout) - let -- Careful, this is really meant to be lazy ~inspectOutput = unsafePerformIO $ internalInspect id - container <- mfix $ \container -> do - -- Note: We have to tie the knot as the resulting container - -- carries the release key as well. - releaseKey <- register $ runResourceT (stop container) - pure $ Container - { - id - , releaseKey - , image - , inspectOutput - } + config <- ask + 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 -> @@ -307,6 +425,9 @@ -- | Internal function that runs Docker. Takes care of throwing an exception -- in case of failure. +-- +-- @since 0.1.0.0 +-- docker :: MonadIO m => [Text] -> m String docker args = dockerWithStdin args "" @@ -314,6 +435,9 @@ -- | Internal function that runs Docker. Takes care of throwing an exception -- in case of failure. +-- +-- @since 0.1.0.0 +-- dockerWithStdin :: MonadIO m => [Text] -> Text -> m String dockerWithStdin args stdin = liftIO $ do (exitCode, stdout, stderr) <- Process.readProcessWithExitCode "docker" @@ -328,28 +452,41 @@ } --- | Kills a Docker container. +-- | Kills a Docker container. `kill` is essentially @docker kill@. +-- +-- @since 0.1.0.0 +-- kill :: MonadDocker m => Container -> m () kill Container { id } = do _ <- docker [ "kill", id ] return () --- | Stops a Docker container. +-- | Stops a Docker container. `stop` is essentially @docker stop@. +-- +-- @since 0.1.0.0 +-- stop :: MonadDocker m => Container -> m () stop Container { id } = do _ <- docker [ "stop", id ] return () --- | Remove a Docker container. +-- | Remove a Docker container. `rm` is essentially @docker rm -f@ +-- +-- @since 0.1.0.0 +-- rm :: MonadDocker m => Container -> m () rm Container { id } = do _ <- docker [ "rm", "-f", "-v", id ] return () --- | Get the logs from a Docker container. +-- | 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 @@ -358,7 +495,7 @@ acquire = liftIO $ Process.runInteractiveProcess "docker" - [ "logs", unpack id ] + [ "logs", "--follow", unpack id ] Nothing Nothing @@ -374,10 +511,16 @@ -- | 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 @@ -389,6 +532,9 @@ -- 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 @@ -400,6 +546,9 @@ -- | 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 { @@ -409,9 +558,12 @@ -- | Get an `Image` from a tag. +-- +-- @since 0.1.0.0 +-- fromTag :: ImageTag -> ToImage -fromTag imageTag = defaultToImage $ do - output <- docker [ "pull", "--quiet", imageTag ] +fromTag tag = defaultToImage $ do + output <- docker [ "pull", "--quiet", tag ] return $ Image { tag = strip (pack output) @@ -420,6 +572,9 @@ -- | 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 @@ -439,6 +594,9 @@ -- | Build a contextless image only from a Dockerfile passed as `Text`. +-- +-- @since 0.1.0.0 +-- fromDockerfile :: Text -> ToImage @@ -451,10 +609,16 @@ -- | Identifies a container within the Docker runtime. Assigned by @docker run@. +-- +-- @since 0.1.0.0 +-- type ContainerId = Text -- | Dumb logger abstraction to allow us to trace container execution. +-- +-- @since 0.1.0.0 +-- data Logger = Logger { debug :: forall m . (HasCallStack, MonadIO m) => Text -> m () @@ -465,6 +629,9 @@ -- | Logger that doesn't log anything. +-- +-- @since 0.1.0.0 +-- silentLogger :: Logger silentLogger = Logger { @@ -477,14 +644,20 @@ -- | 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 :: Logger -> Container -> ResIO () + checkContainerReady :: Logger -> Config -> Container -> 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. @@ -497,6 +670,9 @@ -- | 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. @@ -511,11 +687,14 @@ -- | @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 $ \logger container@Container{ id } -> do +waitUntilTimeout seconds wait = WaitUntilReady $ \logger config container@Container{ id } -> do withRunInIO $ \runInIO -> do result <- timeout (seconds * 1000000) $ - runInIO (checkContainerReady wait logger container) + runInIO (checkContainerReady wait logger config container) case result of Nothing -> throwM $ TimeoutException { id } @@ -525,10 +704,13 @@ -- | 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 $ \logger container -> +waitUntilMappedPortReachable port = WaitUntilReady $ \logger _config container -> withFrozenCallStack $ do let @@ -575,13 +757,19 @@ -- -- 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 $ \_logger container -> do - withLogs container $ \stdout stderr -> +waitWithLogs waiter = WaitUntilReady $ \_logger config container -> do + flip runReaderT config $ withLogs container $ \stdout stderr -> liftIO $ waiter container stdout 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 @@ -598,6 +786,9 @@ -- @ -- wairForLogLine 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 @@ -623,12 +814,19 @@ -- | 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 waiter = - liftResourceT $ checkContainerReady waiter silentLogger container +waitUntilReady container waiter = do + config <- ask + liftResourceT $ checkContainerReady waiter silentLogger config container -- | Handle to a Docker image. +-- +-- @since 0.1.0.0 +-- data Image = Image { -- | The image tag assigned by Docker. Uniquely identifies an `Image` @@ -640,11 +838,17 @@ -- | 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`. @@ -653,21 +857,32 @@ , 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 @@ -675,17 +890,29 @@ -- | 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 Container { id, inspectOutput } = +containerIp container@Container { config = Config { configContainerIp } } = + configContainerIp container + + +-- | Get the IP address of a running Docker container using @docker inspect@. +internalContainerIp :: Container -> Text +internalContainerIp Container { id, inspectOutput } = case inspectOutput - ^? Lens.key "NetworkSettings" - . Lens.key "IPAddress" - . Lens._String of + ^? Optics.key "NetworkSettings" + % Optics.key "IPAddress" + % Optics._String of Nothing -> throw $ InspectOutputUnexpected { id } @@ -695,6 +922,9 @@ -- | Looks up an exposed port on the host. +-- +-- @since 0.1.0.0 +-- containerPort :: Container -> Int -> Int containerPort Container { id, inspectOutput } port = let @@ -706,12 +936,12 @@ -- port from the right host address case inspectOutput - ^? Lens.key "NetworkSettings" - . Lens.key "Ports" - . Lens.key textPort - . Lens.values - . Lens.key "HostPort" - . Lens._String of + ^? pre (Optics.key "NetworkSettings" + % Optics.key "Ports" + % Optics.key textPort + % Optics.values + % Optics.key "HostPort" + % Optics._String) of Nothing -> throw $ UnknownPortMapping @@ -724,12 +954,18 @@ -- | 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) => ContainerId -> m InspectOutput internalInspect id = do stdout <- docker [ "inspect", id ] @@ -742,3 +978,15 @@ pure value Just _ -> Prelude.error "Internal: Multiple results where I expected single result" + + +dockerVersion :: (MonadResource m, MonadMask m, MonadIO m) => m Text +dockerVersion = do + stdout <- docker [ "version", "--format", "{{.Server.KernelVersion}}" ] + return (pack stdout) + + +isDockerForDesktop :: (MonadResource m, MonadMask m, MonadIO m) => m Bool +isDockerForDesktop = do + version <- dockerVersion + pure $ "linuxkit" `isInfixOf` version diff --git a/src/TestContainers/Hspec.hs b/src/TestContainers/Hspec.hs --- a/src/TestContainers/Hspec.hs +++ b/src/TestContainers/Hspec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module TestContainers.Hspec @@ -11,6 +12,7 @@ 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, @@ -46,13 +48,17 @@ -> IO () withContainers startContainers = dropState $ bracket acquire release where + runC action = do + config <- determineConfig + runReaderT (runResourceT action) config + acquire :: IO (a, InternalState) - acquire = runResourceT $ do - result <- startContainers - releaseMap <- getInternalState + acquire = runC $ do + result <- startContainers + releaseMap <- getInternalState - liftIO $ stateAlloc releaseMap - pure (result, releaseMap) + liftIO $ stateAlloc releaseMap + pure (result, releaseMap) release :: (a, InternalState) -> IO () release (_, internalState) = diff --git a/src/TestContainers/Image.hs b/src/TestContainers/Image.hs --- a/src/TestContainers/Image.hs +++ b/src/TestContainers/Image.hs @@ -21,6 +21,9 @@ -- @ -- redis = fromTag "redis:5.0" -- @ +-- +-- @since 0.1.0.0 +-- redis :: ToImage redis = fromTag "redis:5.0" @@ -31,6 +34,9 @@ -- @ -- mongo = Tag "mongo:4.0.17" -- @ +-- +-- @since 0.1.0.0 +-- mongo :: ToImage mongo = fromTag "mongo:4.0.17" diff --git a/src/TestContainers/Tasty.hs b/src/TestContainers/Tasty.hs --- a/src/TestContainers/Tasty.hs +++ b/src/TestContainers/Tasty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module TestContainers.Tasty @@ -10,6 +11,7 @@ ) where import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (runReaderT) import Control.Monad.Trans.Resource (InternalState, getInternalState, runResourceT) @@ -21,7 +23,7 @@ import TestContainers (Container, ContainerRequest, MonadDocker, ToImage, - run, stop) + stop) import TestContainers as Reexports @@ -58,13 +60,17 @@ -> TestTree withContainers startContainers tests = let + runC action = do + config <- determineConfig + runReaderT (runResourceT action) config + -- 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 = runResourceT $ do + acquire = runC $ do result <- startContainers releaseMap <- getInternalState diff --git a/test/TestContainers/HspecSpec.hs b/test/TestContainers/HspecSpec.hs --- a/test/TestContainers/HspecSpec.hs +++ b/test/TestContainers/HspecSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} module TestContainers.HspecSpec(main, spec_all) where import Test.Hspec diff --git a/test/TestContainers/TastySpec.hs b/test/TestContainers/TastySpec.hs --- a/test/TestContainers/TastySpec.hs +++ b/test/TestContainers/TastySpec.hs @@ -1,27 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module TestContainers.TastySpec(main, test_all) where -import Control.Monad.IO.Class (liftIO) -import Data.Text (unpack) +import Data.Text.Lazy (isInfixOf) import Test.Tasty import Test.Tasty.HUnit -import TestContainers.Tasty (MonadDocker, containerIp, - containerPort, containerRequest, redis, - run, setExpose, setWaitingFor, - waitUntilMappedPortReachable, - waitUntilTimeout, withContainers, (&)) +import TestContainers.Tasty (MonadDocker, Pipe (Stdout), + containerRequest, fromTag, redis, run, + setExpose, setRm, setWaitingFor, + waitForLogLine, + waitUntilMappedPortReachable, + waitUntilTimeout, withContainers, (&)) containers1 :: MonadDocker m => m () containers1 = do - redisContainer <- run $ containerRequest redis + _redisContainer <- run $ containerRequest redis & setExpose [ 6379 ] & setWaitingFor (waitUntilTimeout 30 $ waitUntilMappedPortReachable 6379) - liftIO $ - print $ unpack (containerIp redisContainer) <> ":" <> show (containerPort redisContainer 6379) + _rabbitmq <- run $ containerRequest (fromTag "rabbitmq:3.8.4") + & setRm False + & setWaitingFor (waitForLogLine Stdout (("completed with" `isInfixOf`))) pure () diff --git a/testcontainers.cabal b/testcontainers.cabal --- a/testcontainers.cabal +++ b/testcontainers.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: testcontainers -version: 0.1.0.0 +version: 0.2.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 @@ -30,15 +30,16 @@ -- other-extensions: build-depends: base >=4.12 && <5, aeson >= 1.4.6 && < 1.5, + aeson-optics >= 1.1 && < 1.2, bytestring >= 0.10.8 && < 0.11, text >= 1.2.3 && < 1.3, exceptions >= 0.10.4 && < 0.11, - lens >= 4.19.2 && < 5, + optics-core >= 0.1 && < 0.4, process >= 1.6.5 && < 1.7, - lens-aeson >= 1.1 && < 1.2, - network >= 2.8.0 && < 2.9, + network >= 2.8.0 && < 3.2, + mtl >= 2.2.2 && < 2.3, resourcet >= 1.2.4 && < 1.3, - unliftio-core >= 0.2.0 && < 0.3, + unliftio-core >= 0.1.0 && < 0.3, tasty >= 1.0 && < 1.4 hs-source-dirs: src