{-# 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,
    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
  { ContainerRequest -> ToImage
toImage :: ToImage,
    ContainerRequest -> Maybe [Text]
cmd :: Maybe [Text],
    ContainerRequest -> [(Text, Text)]
env :: [(Text, Text)],
    ContainerRequest -> [Port]
exposedPorts :: [Port],
    ContainerRequest -> [(Text, Text)]
volumeMounts :: [(Text, Text)],
    ContainerRequest -> Maybe (Either Network Text)
network :: Maybe (Either Network Text),
    ContainerRequest -> Maybe Text
networkAlias :: Maybe Text,
    ContainerRequest -> [Text]
links :: [ContainerId],
    ContainerRequest -> NamingStrategy
naming :: NamingStrategy,
    ContainerRequest -> Bool
rmOnExit :: Bool,
    ContainerRequest -> WaitUntilReady
readiness :: WaitUntilReady,
    ContainerRequest -> [(Text, Text)]
labels :: [(Text, Text)],
    ContainerRequest -> Bool
noReaper :: Bool,
    ContainerRequest -> Maybe LogConsumer
followLogs :: Maybe LogConsumer
  }

-- | Parameters for a naming a Docker container.
--
-- @since 0.5.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 :: ToImage -> ContainerRequest
containerRequest ToImage
image =
  ContainerRequest
    { $sel:toImage:ContainerRequest :: ToImage
toImage = ToImage
image,
      $sel:naming:ContainerRequest :: NamingStrategy
naming = NamingStrategy
RandomName,
      $sel:cmd:ContainerRequest :: Maybe [Text]
cmd = forall a. Maybe a
Nothing,
      $sel:env:ContainerRequest :: [(Text, Text)]
env = [],
      $sel:exposedPorts:ContainerRequest :: [Port]
exposedPorts = [],
      $sel:volumeMounts:ContainerRequest :: [(Text, Text)]
volumeMounts = [],
      $sel:network:ContainerRequest :: Maybe (Either Network Text)
network = forall a. Maybe a
Nothing,
      $sel:networkAlias:ContainerRequest :: Maybe Text
networkAlias = forall a. Maybe a
Nothing,
      $sel:links:ContainerRequest :: [Text]
links = [],
      $sel:rmOnExit:ContainerRequest :: Bool
rmOnExit = Bool
False,
      $sel:readiness:ContainerRequest :: WaitUntilReady
readiness = forall a. Monoid a => a
mempty,
      $sel:labels:ContainerRequest :: [(Text, Text)]
labels = forall a. Monoid a => a
mempty,
      $sel:noReaper:ContainerRequest :: Bool
noReaper = Bool
False,
      $sel:followLogs:ContainerRequest :: Maybe LogConsumer
followLogs = forall a. Maybe a
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 :: Text -> ContainerRequest -> ContainerRequest
setName = Text -> ContainerRequest -> ContainerRequest
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.5.0.0
setFixedName :: Text -> ContainerRequest -> ContainerRequest
setFixedName :: Text -> ContainerRequest -> ContainerRequest
setFixedName Text
newName ContainerRequest
req =
  -- TODO error on empty Text
  ContainerRequest
req {$sel:naming:ContainerRequest :: NamingStrategy
naming = Text -> NamingStrategy
FixedName Text
newName}

-- | Set the name randomly given of a Docker container. This is equivalent to omitting
--  the @--name@ parameter calling @docker run@.
--
-- @since 0.5.0.0
setRandomName :: ContainerRequest -> ContainerRequest
setRandomName :: ContainerRequest -> ContainerRequest
setRandomName ContainerRequest
req =
  -- TODO error on empty Text
  ContainerRequest
req {$sel:naming:ContainerRequest :: NamingStrategy
naming = NamingStrategy
RandomName}

-- | Set the name randomly suffixed of a Docker container. This is equivalent to invoking
-- @docker run@ with the @--name@ parameter.
--
-- @since 0.5.0.0
setSuffixedName :: Text -> ContainerRequest -> ContainerRequest
setSuffixedName :: Text -> ContainerRequest -> ContainerRequest
setSuffixedName Text
preffix ContainerRequest
req =
  -- TODO error on empty Text
  ContainerRequest
req {$sel:naming:ContainerRequest :: NamingStrategy
naming = Text -> NamingStrategy
SuffixedName Text
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 :: [Text] -> ContainerRequest -> ContainerRequest
setCmd [Text]
newCmd ContainerRequest
req =
  ContainerRequest
req {$sel:cmd:ContainerRequest :: Maybe [Text]
cmd = forall a. a -> Maybe a
Just [Text]
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 :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
setVolumeMounts [(Text, Text)]
newVolumeMounts ContainerRequest
req =
  ContainerRequest
req {$sel:volumeMounts:ContainerRequest :: [(Text, Text)]
volumeMounts = [(Text, Text)]
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 :: Bool -> ContainerRequest -> ContainerRequest
setRm Bool
newRm ContainerRequest
req =
  ContainerRequest
req {$sel:rmOnExit:ContainerRequest :: Bool
rmOnExit = Bool
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 :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
setEnv [(Text, Text)]
newEnv ContainerRequest
req =
  ContainerRequest
req {$sel:env:ContainerRequest :: [(Text, Text)]
env = [(Text, Text)]
newEnv}

-- | Set the network the container will connect to. This is equivalent to passing
-- @--network network_name@ to @docker run@.
--
-- @since 0.5.0.0
withNetwork :: Network -> ContainerRequest -> ContainerRequest
withNetwork :: Network -> ContainerRequest -> ContainerRequest
withNetwork Network
network ContainerRequest
req =
  ContainerRequest
req {$sel:network:ContainerRequest :: Maybe (Either Network Text)
network = forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left Network
network)}

-- | Set the network alias for this container. This is equivalent to passing
-- @--network-alias alias@ to @docker run@.
--
-- @since 0.5.0.0
withNetworkAlias :: Text -> ContainerRequest -> ContainerRequest
withNetworkAlias :: Text -> ContainerRequest -> ContainerRequest
withNetworkAlias Text
alias ContainerRequest
req =
  ContainerRequest
req {$sel:networkAlias:ContainerRequest :: Maybe Text
networkAlias = forall a. a -> Maybe a
Just Text
alias}

-- | Sets labels for a container
--
-- @since 0.5.0.0
withLabels :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
withLabels :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
withLabels [(Text, Text)]
xs ContainerRequest
request =
  ContainerRequest
request {$sel:labels:ContainerRequest :: [(Text, Text)]
labels = [(Text, Text)]
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 :: [Text] -> ContainerRequest -> ContainerRequest
setLink [Text]
newLink ContainerRequest
req =
  ContainerRequest
req {$sel:links:ContainerRequest :: [Text]
links = [Text]
newLink}

-- | Forwards container logs to the given 'LogConsumer' once ran.
--
-- @since 0.5.0.0
withFollowLogs :: LogConsumer -> ContainerRequest -> ContainerRequest
withFollowLogs :: LogConsumer -> ContainerRequest -> ContainerRequest
withFollowLogs LogConsumer
logConsumer ContainerRequest
request =
  ContainerRequest
request {$sel:followLogs:ContainerRequest :: Maybe LogConsumer
followLogs = forall a. a -> Maybe a
Just LogConsumer
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
port :: Int,
    Port -> Text
protocol :: Text
  }
  deriving stock (Port -> Port -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c== :: Port -> Port -> Bool
Eq, Eq Port
Port -> Port -> Bool
Port -> Port -> Ordering
Port -> Port -> Port
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Port -> Port -> Port
$cmin :: Port -> Port -> Port
max :: Port -> Port -> Port
$cmax :: Port -> Port -> Port
>= :: Port -> Port -> Bool
$c>= :: Port -> Port -> Bool
> :: Port -> Port -> Bool
$c> :: Port -> Port -> Bool
<= :: Port -> Port -> Bool
$c<= :: Port -> Port -> Bool
< :: Port -> Port -> Bool
$c< :: Port -> Port -> Bool
compare :: Port -> Port -> Ordering
$ccompare :: Port -> Port -> Ordering
Ord)

defaultProtocol :: Text
defaultProtocol :: Text
defaultProtocol = Text
"tcp"

-- @since 0.5.0.0
instance Show Port where
  show :: Port -> String
show Port {Int
port :: Int
$sel:port:Port :: Port -> Int
port, Text
protocol :: Text
$sel:protocol:Port :: Port -> Text
protocol} =
    forall a. Show a => a -> String
show Int
port forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
protocol

-- | A cursed but handy instance supporting literal 'Port's.
--
-- @since 0.5.0.0
instance Num Port where
  fromInteger :: Integer -> Port
fromInteger Integer
x =
    Port {$sel:port:Port :: Int
port = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x, $sel:protocol:Port :: Text
protocol = Text
defaultProtocol}
  + :: Port -> Port -> Port
(+) = forall a. HasCallStack => String -> a
Prelude.error String
"not implemented"
  * :: Port -> Port -> Port
(*) = forall a. HasCallStack => String -> a
Prelude.error String
"not implemented"
  abs :: Port -> Port
abs = forall a. HasCallStack => String -> a
Prelude.error String
"not implemented"
  signum :: Port -> Port
signum = forall a. HasCallStack => String -> a
Prelude.error String
"not implemented"
  negate :: Port -> Port
negate = forall a. HasCallStack => String -> a
Prelude.error String
"not implemented"

-- | A cursed but handy instance supporting literal 'Port's of them
-- form @"8080"@, @"8080/udp"@, @"8080/tcp"@.
--
-- @since 0.5.0.0
instance IsString Port where
  fromString :: String -> Port
fromString String
input = case Text -> Text -> [Text]
splitOn Text
"/" (String -> Text
pack String
input) of
    [Text
numberish]
      | Right (Int
port, Text
"") <- forall a. Integral a => Reader a
decimal Text
numberish ->
          Port {Int
port :: Int
$sel:port:Port :: Int
port, $sel:protocol:Port :: Text
protocol = Text
defaultProtocol}
    [Text
numberish, Text
protocol]
      | Right (Int
port, Text
"") <- forall a. Integral a => Reader a
decimal Text
numberish ->
          Port {Int
port :: Int
$sel:port:Port :: Int
port, Text
protocol :: Text
$sel:protocol:Port :: Text
protocol}
    [Text]
_ ->
      forall a. HasCallStack => String -> a
Prelude.error (String
"invalid port literal: " forall a. Semigroup a => a -> a -> a
<> String
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 :: [Port] -> ContainerRequest -> ContainerRequest
setExpose [Port]
newExpose ContainerRequest
req =
  ContainerRequest
req {$sel:exposedPorts:ContainerRequest :: [Port]
exposedPorts = [Port]
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 :: WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor WaitUntilReady
newWaitingFor ContainerRequest
req =
  ContainerRequest
req {$sel:readiness:ContainerRequest :: WaitUntilReady
readiness = WaitUntilReady
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 :: ContainerRequest -> TestContainer Container
run ContainerRequest
request = do
  let ContainerRequest
        { ToImage
toImage :: ToImage
$sel:toImage:ContainerRequest :: ContainerRequest -> ToImage
toImage,
          NamingStrategy
naming :: NamingStrategy
$sel:naming:ContainerRequest :: ContainerRequest -> NamingStrategy
naming,
          Maybe [Text]
cmd :: Maybe [Text]
$sel:cmd:ContainerRequest :: ContainerRequest -> Maybe [Text]
cmd,
          [(Text, Text)]
env :: [(Text, Text)]
$sel:env:ContainerRequest :: ContainerRequest -> [(Text, Text)]
env,
          [Port]
exposedPorts :: [Port]
$sel:exposedPorts:ContainerRequest :: ContainerRequest -> [Port]
exposedPorts,
          [(Text, Text)]
volumeMounts :: [(Text, Text)]
$sel:volumeMounts:ContainerRequest :: ContainerRequest -> [(Text, Text)]
volumeMounts,
          Maybe (Either Network Text)
network :: Maybe (Either Network Text)
$sel:network:ContainerRequest :: ContainerRequest -> Maybe (Either Network Text)
network,
          Maybe Text
networkAlias :: Maybe Text
$sel:networkAlias:ContainerRequest :: ContainerRequest -> Maybe Text
networkAlias,
          [Text]
links :: [Text]
$sel:links:ContainerRequest :: ContainerRequest -> [Text]
links,
          Bool
rmOnExit :: Bool
$sel:rmOnExit:ContainerRequest :: ContainerRequest -> Bool
rmOnExit,
          WaitUntilReady
readiness :: WaitUntilReady
$sel:readiness:ContainerRequest :: ContainerRequest -> WaitUntilReady
readiness,
          [(Text, Text)]
labels :: [(Text, Text)]
$sel:labels:ContainerRequest :: ContainerRequest -> [(Text, Text)]
labels,
          Bool
noReaper :: Bool
$sel:noReaper:ContainerRequest :: ContainerRequest -> Bool
noReaper,
          Maybe LogConsumer
followLogs :: Maybe LogConsumer
$sel:followLogs:ContainerRequest :: ContainerRequest -> Maybe LogConsumer
followLogs
        } = ContainerRequest
request

  config :: Config
config@Config {Tracer
configTracer :: Config -> Tracer
configTracer :: Tracer
configTracer, TestContainer Reaper
configCreateReaper :: Config -> TestContainer Reaper
configCreateReaper :: TestContainer Reaper
configCreateReaper} <-
    forall r (m :: * -> *). MonadReader r m => m r
ask

  [(Text, Text)]
additionalLabels <-
    if Bool
noReaper
      then do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      else Reaper -> [(Text, Text)]
reaperLabels forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestContainer Reaper
configCreateReaper

  image :: Image
image@Image {Text
$sel:tag:Image :: Image -> Text
tag :: Text
tag} <- ToImage -> TestContainer Image
runToImage ToImage
toImage

  Maybe Text
name <-
    case NamingStrategy
naming of
      NamingStrategy
RandomName -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      FixedName Text
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
n
      SuffixedName Text
prefix ->
        forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
prefix forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"-" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
6 (forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
Random.randomRIO (Char
'a', Char
'z'))

  let dockerRun :: [Text]
      dockerRun :: [Text]
dockerRun =
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
          [[Text
"run"]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--detach"]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--name", Text
containerName] | Just Text
containerName <- [Maybe Text
name]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--label", Text
label forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
value] | (Text
label, Text
value) <- [(Text, Text)]
additionalLabels forall a. [a] -> [a] -> [a]
++ [(Text, Text)]
labels]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--env", Text
variable forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
value] | (Text
variable, Text
value) <- [(Text, Text)]
env]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--publish", String -> Text
pack (forall a. Show a => a -> String
show Int
port) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
protocol] | Port {Int
port :: Int
$sel:port:Port :: Port -> Int
port, Text
protocol :: Text
$sel:protocol:Port :: Port -> Text
protocol} <- [Port]
exposedPorts]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--network", Text
networkName] | Just (Right Text
networkName) <- [Maybe (Either Network Text)
network]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--network", Network -> Text
networkId Network
dockerNetwork] | Just (Left Network
dockerNetwork) <- [Maybe (Either Network Text)
network]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--network-alias", Text
alias] | Just Text
alias <- [Maybe Text
networkAlias]]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--link", Text
container] | Text
container <- [Text]
links]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--volume", Text
src forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
dest] | (Text
src, Text
dest) <- [(Text, Text)]
volumeMounts]
            forall a. [a] -> [a] -> [a]
++ [[Text
"--rm"] | Bool
rmOnExit]
            forall a. [a] -> [a] -> [a]
++ [[Text
tag]]
            forall a. [a] -> [a] -> [a]
++ [[Text]
command | Just [Text]
command <- [Maybe [Text]
cmd]]

  String
stdout <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
configTracer [Text]
dockerRun

  let id :: ContainerId
      !id :: Text
id =
        -- N.B. Force to not leak STDOUT String
        Text -> Text
strip (String -> Text
pack String
stdout)

      -- Careful, this is really meant to be lazy
      ~InspectOutput
inspectOutput =
        forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Tracer -> Text -> m InspectOutput
internalInspect Tracer
configTracer Text
id

  -- We don't issue 'ReleaseKeys' for cleanup anymore. Ryuk takes care of cleanup
  -- for us once the session has been closed.
  ReleaseKey
releaseKey <- forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe LogConsumer
followLogs forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
MonadResource m =>
Tracer -> Text -> LogConsumer -> m ()
dockerFollowLogs Tracer
configTracer Text
id

  let container :: Container
container =
        Container
          { Text
$sel:id:Container :: Text
id :: Text
id,
            ReleaseKey
$sel:releaseKey:Container :: ReleaseKey
releaseKey :: ReleaseKey
releaseKey,
            Image
$sel:image:Container :: Image
image :: Image
image,
            InspectOutput
$sel:inspectOutput:Container :: InspectOutput
inspectOutput :: InspectOutput
inspectOutput,
            Config
$sel:config:Container :: Config
config :: Config
config
          }

  -- Last but not least, execute the WaitUntilReady checks
  Container -> WaitUntilReady -> TestContainer ()
waitUntilReady Container
container WaitUntilReady
readiness

  forall (f :: * -> *) a. Applicative f => a -> f a
pure Container
container

-- | Sets up a Ryuk 'Reaper'.
--
-- @since 0.5.0.0
createRyukReaper :: TestContainer Reaper
createRyukReaper :: TestContainer Reaper
createRyukReaper = do
  Container
ryukContainer <-
    ContainerRequest -> TestContainer Container
run forall a b. (a -> b) -> a -> b
$
      ToImage -> ContainerRequest
containerRequest (Text -> ToImage
fromTag Text
ryukImageTag)
        forall a b. a -> (a -> b) -> b
& ContainerRequest -> ContainerRequest
skipReaper
        forall a b. a -> (a -> b) -> b
& [(Text, Text)] -> ContainerRequest -> ContainerRequest
setVolumeMounts [(Text
"/var/run/docker.sock", Text
"/var/run/docker.sock")]
        forall a b. a -> (a -> b) -> b
& [Port] -> ContainerRequest -> ContainerRequest
setExpose [forall a. Num a => a
ryukPort]
        forall a b. a -> (a -> b) -> b
& WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor (Port -> WaitUntilReady
waitUntilMappedPortReachable forall a. Num a => a
ryukPort)
        forall a b. a -> (a -> b) -> b
& Bool -> ContainerRequest -> ContainerRequest
setRm Bool
True

  let (Text
ryukContainerAddress, Int
ryukContainerPort) =
        Container -> Port -> (Text, Int)
containerAddress Container
ryukContainer forall a. Num a => a
ryukPort

  forall (m :: * -> *). MonadResource m => Text -> Int -> m Reaper
newRyukReaper Text
ryukContainerAddress Int
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 :: ContainerRequest -> ContainerRequest
skipReaper ContainerRequest
request =
  ContainerRequest
request {$sel:noReaper:ContainerRequest :: Bool
noReaper = Bool
True}

-- | Kills a Docker container. `kill` is essentially @docker kill@.
--
-- @since 0.1.0.0
kill :: Container -> TestContainer ()
kill :: Container -> TestContainer ()
kill Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} = do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
_ <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"kill", Text
id]
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Stops a Docker container. `stop` is essentially @docker stop@.
--
-- @since 0.1.0.0
stop :: Container -> TestContainer ()
stop :: Container -> TestContainer ()
stop Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} = do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
_ <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"stop", Text
id]
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Remove a Docker container. `rm` is essentially @docker rm -f@
--
-- @since 0.1.0.0
rm :: Container -> TestContainer ()
rm :: Container -> TestContainer ()
rm Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} = do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
_ <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"rm", Text
"-f", Text
"-v", Text
id]
  forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall a.
Container
-> (Handle -> Handle -> TestContainer a) -> TestContainer a
withLogs Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} Handle -> Handle -> TestContainer a
logger = do
  let acquire :: TestContainer (Handle, Handle, Handle, Process.ProcessHandle)
      acquire :: TestContainer (Handle, Handle, Handle, ProcessHandle)
acquire =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
Process.runInteractiveProcess
            String
"docker"
            [String
"logs", String
"--follow", Text -> String
unpack Text
id]
            forall a. Maybe a
Nothing
            forall a. Maybe a
Nothing

      release :: (Handle, Handle, Handle, Process.ProcessHandle) -> TestContainer ()
      release :: (Handle, Handle, Handle, ProcessHandle) -> TestContainer ()
release (Handle
stdin, Handle
stdout, Handle
stderr, ProcessHandle
handle) =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Process.cleanupProcess
            (forall a. a -> Maybe a
Just Handle
stdin, forall a. a -> Maybe a
Just Handle
stdout, forall a. a -> Maybe a
Just Handle
stderr, ProcessHandle
handle)

  forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket TestContainer (Handle, Handle, Handle, ProcessHandle)
acquire (Handle, Handle, Handle, ProcessHandle) -> TestContainer ()
release forall a b. (a -> b) -> a -> b
$ \(Handle
stdin, Handle
stdout, Handle
stderr, ProcessHandle
_handle) -> do
    -- No need to keep it around...
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
stdin
    Handle -> Handle -> TestContainer a
logger Handle
stdout Handle
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
  { ToImage -> TestContainer Image
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 -> TestContainer ToImage
build ToImage
toImage = do
  Image
image <- ToImage -> TestContainer Image
runToImage ToImage
toImage
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    ToImage
toImage
      { $sel:runToImage:ToImage :: TestContainer Image
runToImage = forall (f :: * -> *) a. Applicative f => a -> f a
pure Image
image
      }

-- | Default `ToImage`. Doesn't apply anything to to `ContainerRequests`.
--
-- @since 0.1.0.0
defaultToImage :: TestContainer Image -> ToImage
defaultToImage :: TestContainer Image -> ToImage
defaultToImage TestContainer Image
action =
  ToImage
    { $sel:runToImage:ToImage :: TestContainer Image
runToImage = TestContainer Image
action
    }

-- | Get an `Image` from a tag.
--
-- @since 0.1.0.0
fromTag :: ImageTag -> ToImage
fromTag :: Text -> ToImage
fromTag Text
tag = TestContainer Image -> ToImage
defaultToImage forall a b. (a -> b) -> a -> b
$ do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
output <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"pull", Text
"--quiet", Text
tag]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip (String -> Text
pack String
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 :: String -> Maybe String -> ToImage
fromBuildContext String
path Maybe String
mdockerfile = TestContainer Image -> ToImage
defaultToImage forall a b. (a -> b) -> a -> b
$ do
  let args :: [Text]
args
        | Just String
dockerfile <- Maybe String
mdockerfile =
            [Text
"build", Text
"--quiet", Text
"--file", String -> Text
pack String
dockerfile, String -> Text
pack String
path]
        | Bool
otherwise =
            [Text
"build", Text
"--quiet", String -> Text
pack String
path]
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
output <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text]
args
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip (String -> Text
pack String
output)
      }

-- | Build a contextless image only from a Dockerfile passed as `Text`.
--
-- @since 0.1.0.0
fromDockerfile ::
  Text ->
  ToImage
fromDockerfile :: Text -> ToImage
fromDockerfile Text
dockerfile = TestContainer Image -> ToImage
defaultToImage forall a b. (a -> b) -> a -> b
$ do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
output <- forall (m :: * -> *).
MonadIO m =>
Tracer -> [Text] -> Text -> m String
dockerWithStdin Tracer
tracer [Text
"build", Text
"--quiet", Text
"-"] Text
dockerfile
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip (String -> Text
pack String
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.5.0.0
instance Semigroup WaitUntilReady where
  <> :: WaitUntilReady -> WaitUntilReady -> WaitUntilReady
(<>) = WaitUntilReady -> WaitUntilReady -> WaitUntilReady
WaitMany

-- | @since 0.5.0.0
instance Monoid WaitUntilReady where
  mempty :: WaitUntilReady
mempty = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady forall a. Monoid a => a
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.
    UnexpectedEndOfPipe -> Text
id :: ContainerId
  }
  deriving (UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
$c/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
$c== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
Eq, Int -> UnexpectedEndOfPipe -> ShowS
[UnexpectedEndOfPipe] -> ShowS
UnexpectedEndOfPipe -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnexpectedEndOfPipe] -> ShowS
$cshowList :: [UnexpectedEndOfPipe] -> ShowS
show :: UnexpectedEndOfPipe -> String
$cshow :: UnexpectedEndOfPipe -> String
showsPrec :: Int -> UnexpectedEndOfPipe -> ShowS
$cshowsPrec :: Int -> UnexpectedEndOfPipe -> ShowS
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.
    TimeoutException -> Text
id :: ContainerId
  }
  deriving (TimeoutException -> TimeoutException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c== :: TimeoutException -> TimeoutException -> Bool
Eq, Int -> TimeoutException -> ShowS
[TimeoutException] -> ShowS
TimeoutException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutException] -> ShowS
$cshowList :: [TimeoutException] -> ShowS
show :: TimeoutException -> String
$cshow :: TimeoutException -> String
showsPrec :: Int -> TimeoutException -> ShowS
$cshowsPrec :: Int -> TimeoutException -> ShowS
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.
    InvalidStateException -> Text
id :: ContainerId
  }
  deriving stock (InvalidStateException -> InvalidStateException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvalidStateException -> InvalidStateException -> Bool
$c/= :: InvalidStateException -> InvalidStateException -> Bool
== :: InvalidStateException -> InvalidStateException -> Bool
$c== :: InvalidStateException -> InvalidStateException -> Bool
Eq, Int -> InvalidStateException -> ShowS
[InvalidStateException] -> ShowS
InvalidStateException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InvalidStateException] -> ShowS
$cshowList :: [InvalidStateException] -> ShowS
show :: InvalidStateException -> String
$cshow :: InvalidStateException -> String
showsPrec :: Int -> InvalidStateException -> ShowS
$cshowsPrec :: Int -> InvalidStateException -> ShowS
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.5.0.0
waitForState :: (State -> Bool) -> WaitUntilReady
waitForState :: (State -> Bool) -> WaitUntilReady
waitForState State -> Bool
isReady = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady forall a b. (a -> b) -> a -> b
$ \Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} -> do
  let wait :: TestContainer ()
wait = do
        Config {Tracer
configTracer :: Tracer
configTracer :: Config -> Tracer
configTracer} <-
          forall r (m :: * -> *). MonadReader r m => m r
ask
        InspectOutput
inspectOutput <-
          forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Tracer -> Text -> m InspectOutput
internalInspect Tracer
configTracer Text
id

        let state :: State
state = InspectOutput -> State
containerState InspectOutput
inspectOutput

        if State -> Bool
isReady State
state
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else do
            case State -> Status
stateStatus State
state of
              Status
Exited ->
                -- Once exited, state won't change!
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidStateException {Text
id :: Text
$sel:id:InvalidStateException :: Text
id}
              Status
Dead ->
                -- Once dead, state won't change!
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM InvalidStateException {Text
id :: Text
$sel:id:InvalidStateException :: Text
id}
              Status
_ -> do
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
500000)
                TestContainer ()
wait
  TestContainer ()
wait

-- | @successfulExit@ is supposed to be used in conjunction with 'waitForState'.
--
-- @since 0.5.0.0
successfulExit :: State -> Bool
successfulExit :: State -> Bool
successfulExit State
state =
  State -> Status
stateStatus State
state forall a. Eq a => a -> a -> Bool
== Status
Exited Bool -> Bool -> Bool
&& State -> Maybe Int
stateExitCode State
state forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
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 :: Int -> WaitUntilReady -> WaitUntilReady
waitUntilTimeout = Int -> WaitUntilReady -> WaitUntilReady
WaitUntilTimeout

-- | Waits for a specific http status code.
-- This combinator should always be used with `waitUntilTimeout`.
--
-- @since 0.5.0.0
waitForHttp ::
  -- | Port
  Port ->
  -- | URL path
  String ->
  -- | Acceptable status codes
  [Int] ->
  WaitUntilReady
waitForHttp :: Port -> String -> [Int] -> WaitUntilReady
waitForHttp Port
port String
path [Int]
acceptableStatusCodes = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady forall a b. (a -> b) -> a -> b
$ \Container
container -> do
  Config {Tracer
configTracer :: Tracer
configTracer :: Config -> Tracer
configTracer} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let wait :: (MonadIO m, MonadCatch m) => m ()
      wait :: forall (m :: * -> *). (MonadIO m, MonadCatch m) => m ()
wait =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry

      retry :: (MonadIO m, MonadCatch m) => Manager -> m ()
      retry :: forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry Manager
manager = do
        let (Text
endpointHost, Int
endpointPort) =
              Container -> Port -> (Text, Int)
containerAddress Container
container Port
port
        let request :: Request
request =
              Request
defaultRequest
                { host :: ByteString
host = Text -> ByteString
encodeUtf8 Text
endpointHost,
                  port :: Int
port = Int
endpointPort,
                  path :: ByteString
path = Text -> ByteString
encodeUtf8 (String -> Text
pack String
path)
                }
        Either HttpException Int
result <-
          forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$
            Status -> Int
statusCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> Status
responseStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> Manager -> IO (Response ())
httpNoBody Request
request Manager
manager)
        case Either HttpException Int
result of
          Right Int
code -> do
            forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
              Tracer
configTracer
              (Text -> Int -> Either String Int -> Trace
TraceHttpCall Text
endpointHost Int
endpointPort (forall a b. b -> Either a b
Right Int
code))
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
code forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
acceptableStatusCodes) forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry Manager
manager
          Left (HttpException
exception :: HttpException) -> do
            forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
              Tracer
configTracer
              (Text -> Int -> Either String Int -> Trace
TraceHttpCall Text
endpointHost Int
endpointPort (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show HttpException
exception))
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
500000)
            forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry Manager
manager

  forall (m :: * -> *). (MonadIO m, MonadCatch m) => m ()
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 -> WaitUntilReady
waitUntilMappedPortReachable Port
port = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady forall a b. (a -> b) -> a -> b
$ \Container
container -> do
  forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
    Config {Tracer
configTracer :: Tracer
configTracer :: Config -> Tracer
configTracer} <- forall r (m :: * -> *). MonadReader r m => m r
ask

    let resolve :: String -> a -> IO AddrInfo
resolve String
endpointHost a
endpointPort = do
          let hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints {addrSocketType :: SocketType
Socket.addrSocketType = SocketType
Socket.Stream}
          forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just String
endpointHost) (forall a. a -> Maybe a
Just (forall a. Show a => a -> String
show a
endpointPort))

        open :: AddrInfo -> IO Socket
open AddrInfo
addr = do
          Socket
socket <-
            Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket
              (AddrInfo -> Family
Socket.addrFamily AddrInfo
addr)
              (AddrInfo -> SocketType
Socket.addrSocketType AddrInfo
addr)
              (AddrInfo -> ProtocolNumber
Socket.addrProtocol AddrInfo
addr)
          Socket -> SockAddr -> IO ()
Socket.connect
            Socket
socket
            (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
addr)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Socket
socket

        wait :: IO ()
wait = do
          let (Text
endpointHost, Int
endpointPort) =
                Container -> Port -> (Text, Int)
containerAddress Container
container Port
port

          Either IOException Socket
result <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (forall {a}. Show a => String -> a -> IO AddrInfo
resolve (Text -> String
unpack Text
endpointHost) Int
endpointPort forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AddrInfo -> IO Socket
open)
          case Either IOException Socket
result of
            Right Socket
socket -> do
              forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
configTracer (Text -> Int -> Maybe IOException -> Trace
TraceOpenSocket Text
endpointHost Int
endpointPort forall a. Maybe a
Nothing)
              Socket -> IO ()
Socket.close Socket
socket
              forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left (IOException
exception :: IOException) -> do
              forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
                Tracer
configTracer
                (Text -> Int -> Maybe IOException -> Trace
TraceOpenSocket Text
endpointHost Int
endpointPort (forall a. a -> Maybe a
Just IOException
exception))
              Int -> IO ()
threadDelay Int
500000
              IO ()
wait

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
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 :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
waitWithLogs Container -> Handle -> Handle -> IO ()
waiter = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady forall a b. (a -> b) -> a -> b
$ \Container
container ->
  forall a.
Container
-> (Handle -> Handle -> TestContainer a) -> TestContainer a
withLogs Container
container forall a b. (a -> b) -> a -> b
$ \Handle
stdout Handle
stderr ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Container -> Handle -> Handle -> IO ()
waiter Container
container Handle
stdout Handle
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 :: Pipe -> (Text -> Bool) -> WaitUntilReady
waitForLogLine Pipe
whereToLook Text -> Bool
matches = (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
waitWithLogs forall a b. (a -> b) -> a -> b
$ \Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} Handle
stdout Handle
stderr -> do
  let logs :: Handle
      logs :: Handle
logs = case Pipe
whereToLook of
        Pipe
Stdout -> Handle
stdout
        Pipe
Stderr -> Handle
stderr

  ByteString
logContent <- Handle -> IO ByteString
LazyByteString.hGetContents Handle
logs

  let logLines :: [LazyText.Text]
      logLines :: [Text]
logLines =
        -- FIXME: This is assuming UTF8 encoding. Do better!
        forall a b. (a -> b) -> [a] -> [b]
map
          (OnDecodeError -> ByteString -> Text
LazyText.decodeUtf8With OnDecodeError
lenientDecode)
          (ByteString -> [ByteString]
LazyByteString.lines ByteString
logContent)

  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
matches [Text]
logLines of
    Just Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Text
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ UnexpectedEndOfPipe {Text
id :: Text
$sel:id:UnexpectedEndOfPipe :: Text
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 -> WaitUntilReady -> TestContainer ()
waitUntilReady container :: Container
container@Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} WaitUntilReady
input = do
  Config {Maybe Int
configDefaultWaitTimeout :: Config -> Maybe Int
configDefaultWaitTimeout :: Maybe Int
configDefaultWaitTimeout} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  WaitUntilReady -> TestContainer ()
interpreter forall a b. (a -> b) -> a -> b
$ case Maybe Int
configDefaultWaitTimeout of
    Just Int
seconds -> Int -> WaitUntilReady -> WaitUntilReady
waitUntilTimeout Int
seconds WaitUntilReady
input
    Maybe Int
Nothing -> WaitUntilReady
input
  where
    interpreter :: WaitUntilReady -> TestContainer ()
    interpreter :: WaitUntilReady -> TestContainer ()
interpreter WaitUntilReady
wait =
      case WaitUntilReady
wait of
        WaitReady Container -> TestContainer ()
check ->
          Container -> TestContainer ()
check Container
container
        WaitUntilTimeout Int
seconds WaitUntilReady
rest ->
          forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. TestContainer a -> IO a
runInIO -> do
            Maybe ()
result <-
              forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
seconds forall a. Num a => a -> a -> a
* Int
1000000) forall a b. (a -> b) -> a -> b
$
                forall a. TestContainer a -> IO a
runInIO (WaitUntilReady -> TestContainer ()
interpreter WaitUntilReady
rest)
            case Maybe ()
result of
              Maybe ()
Nothing ->
                forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ TimeoutException {Text
id :: Text
$sel:id:TimeoutException :: Text
id}
              Just {} ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        WaitMany WaitUntilReady
first WaitUntilReady
second -> do
          WaitUntilReady -> TestContainer ()
interpreter WaitUntilReady
first
          WaitUntilReady -> TestContainer ()
interpreter WaitUntilReady
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.
    Image -> Text
tag :: ImageTag
  }
  deriving (Image -> Image -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Image -> Image -> Bool
$c/= :: Image -> Image -> Bool
== :: Image -> Image -> Bool
$c== :: Image -> Image -> Bool
Eq, Int -> Image -> ShowS
[Image] -> ShowS
Image -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Image] -> ShowS
$cshowList :: [Image] -> ShowS
show :: Image -> String
$cshow :: Image -> String
showsPrec :: Int -> Image -> ShowS
$cshowsPrec :: Int -> Image -> ShowS
Show)

-- | The image tag assigned by Docker. Uniquely identifies an `Image`
-- within Docker.
--
-- @since 0.1.0.0
imageTag :: Image -> ImageTag
imageTag :: Image -> Text
imageTag Image {Text
tag :: Text
$sel:tag:Image :: Image -> Text
tag} = Text
tag

-- | Handle to a Docker container.
--
-- @since 0.1.0.0
data Container = Container
  { -- | The container Id assigned by Docker, uniquely identifying this `Container`.
    Container -> Text
id :: ContainerId,
    -- | Underlying `ReleaseKey` for the resource finalizer.
    Container -> ReleaseKey
releaseKey :: ReleaseKey,
    -- | The underlying `Image` of this container.
    Container -> Image
image :: Image,
    -- | Configuration used to create and run this container.
    Container -> Config
config :: Config,
    -- | Memoized output of `docker inspect`. This is being calculated lazily.
    Container -> InspectOutput
inspectOutput :: InspectOutput
  }

-- | Returns the id of the container.
--
-- @since 0.1.0.0
containerId :: Container -> ContainerId
containerId :: Container -> Text
containerId Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id} = Text
id

-- | Returns the underlying image of the container.
--
-- @since 0.1.0.0
containerImage :: Container -> Image
containerImage :: Container -> Image
containerImage Container {Image
image :: Image
$sel:image:Container :: Container -> Image
image} = 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
containerReleaseKey Container {ReleaseKey
releaseKey :: ReleaseKey
$sel:releaseKey:Container :: Container -> ReleaseKey
releaseKey} = 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 :: Container -> Text
containerIp =
  Container -> Text
internalContainerIp

-- | Get the IP address of a running Docker container using @docker inspect@.
internalContainerIp :: Container -> Text
internalContainerIp :: Container -> Text
internalContainerIp Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id, InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
    forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"IPAddress"
    forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Prism' t Text
Optics._String of
    Maybe Text
Nothing ->
      forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ InspectOutputUnexpected {Text
id :: Text
id :: Text
id}
    Just Text
address ->
      Text
address

-- | Get the container's network alias.
-- Takes the first alias found.
--
-- @since 0.5.0.0
containerAlias :: Container -> Text
containerAlias :: Container -> Text
containerAlias Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id, InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
      ( forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Networks"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => IxTraversal' Key t InspectOutput
Optics.members
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Aliases"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => IxTraversal' Int t InspectOutput
Optics.values
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Prism' t Text
Optics._String
      ) of
    Maybe Text
Nothing ->
      forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$
        InspectOutputMissingNetwork
          { Text
id :: Text
id :: Text
id
          }
    Just Text
alias ->
      Text
alias

-- | Get the IP address for the container's gateway, i.e. the host.
-- Takes the first gateway address found.
--
-- @since 0.5.0.0
containerGateway :: Container -> Text
containerGateway :: Container -> Text
containerGateway Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id, InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
      ( forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Networks"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => IxTraversal' Key t InspectOutput
Optics.members
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Gateway"
          forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Prism' t Text
Optics._String
      ) of
    Maybe Text
Nothing ->
      forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$
        InspectOutputMissingNetwork
          { Text
id :: Text
id :: Text
id
          }
    Just Text
gatewayIp ->
      Text
gatewayIp

-- | Looks up an exposed port on the host.
--
-- @since 0.1.0.0
containerPort :: Container -> Port -> Int
containerPort :: Container -> Port -> Int
containerPort Container {Text
id :: Text
$sel:id:Container :: Container -> Text
id, InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput} Port {Int
port :: Int
$sel:port:Port :: Port -> Int
port, Text
protocol :: Text
$sel:protocol:Port :: Port -> Text
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 :: forall s. IsString s => s
textPort = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
port forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
protocol
   in -- TODO be more mindful, make sure to grab the
      -- port from the right host address

      case InspectOutput
inspectOutput
        forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
          ( forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
              forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Ports"
              forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key forall s. IsString s => s
textPort
              forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => IxTraversal' Int t InspectOutput
Optics.values
              forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"HostPort"
              forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% forall t. AsValue t => Prism' t Text
Optics._String
          ) of
        Maybe Text
Nothing ->
          forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$
            UnknownPortMapping
              { Text
id :: Text
id :: Text
id,
                port :: Text
port = forall s. IsString s => s
textPort
              }
        Just Text
hostPort ->
          forall a. Read a => String -> a
read (Text -> String
unpack Text
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.5.0.0
containerAddress :: Container -> Port -> (Text, Int)
containerAddress :: Container -> Port -> (Text, Int)
containerAddress Container
container Port {Int
port :: Int
$sel:port:Port :: Port -> Int
port, Text
protocol :: Text
$sel:protocol:Port :: Port -> Text
protocol} =
  let inDocker :: Bool
inDocker = forall a. IO a -> a
unsafePerformIO forall (m :: * -> *). MonadIO m => m Bool
isRunningInDocker
   in if Bool
inDocker
        then (Container -> Text
containerAlias Container
container, Int
port)
        else (Text
"localhost", Container -> Port -> Int
containerPort Container
container (Port {Int
port :: Int
$sel:port:Port :: Int
port, Text
protocol :: Text
$sel:protocol:Port :: Text
protocol}))

-- | Runs the `docker inspect` command. Memoizes the result.
--
-- @since 0.1.0.0
inspect :: Container -> TestContainer InspectOutput
inspect :: Container -> TestContainer InspectOutput
inspect Container {InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure InspectOutput
inspectOutput

-- | Runs the `docker inspect` command.
--
-- @since 0.1.0.0
internalInspect :: (MonadThrow m, MonadIO m) => Tracer -> ContainerId -> m InspectOutput
internalInspect :: forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Tracer -> Text -> m InspectOutput
internalInspect Tracer
tracer Text
id = do
  String
stdout <- forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"inspect", Text
id]
  case forall a. FromJSON a => ByteString -> Maybe a
decode' (String -> ByteString
LazyByteString.pack String
stdout) of
    Maybe [InspectOutput]
Nothing ->
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ InspectOutputInvalidJSON {Text
id :: Text
id :: Text
id}
    Just [] ->
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ InspectUnknownContainerId {Text
id :: Text
id :: Text
id}
    Just [InspectOutput
value] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure InspectOutput
value
    Just [InspectOutput]
_ ->
      forall a. HasCallStack => String -> a
Prelude.error String
"Internal: Multiple results where I expected single result"

askTracer :: (MonadReader Config m) => m Tracer
askTracer :: forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer = do
  Config {Tracer
configTracer :: Tracer
configTracer :: Config -> Tracer
configTracer} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer
configTracer
{-# INLINE askTracer #-}

dockerHostOs :: TestContainer Text
dockerHostOs :: TestContainer Text
dockerHostOs = do
  Tracer
tracer <- forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  Text -> Text
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [Text
"version", Text
"--format", Text
"{{.Server.Os}}"]

isDockerOnLinux :: TestContainer Bool
isDockerOnLinux :: TestContainer Bool
isDockerOnLinux =
  (Text
"linux" forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestContainer Text
dockerHostOs

-- | Detects if we are actually running in a Docker container.
isRunningInDocker :: (MonadIO m) => m Bool
isRunningInDocker :: forall (m :: * -> *). MonadIO m => m Bool
isRunningInDocker = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
"/.dockerenv"