{-# 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,
    fromImageId,
    fromBuildContext,
    fromDockerfile,
    build,

    -- * Exceptions
    DockerException (..),

    -- * Running containers
    ContainerRequest,
    containerRequest,
    withoutReaper,
    withLabels,
    setName,
    setFixedName,
    setSuffixedName,
    setRandomName,
    setCmd,
    setMemory,
    setCpus,
    setVolumeMounts,
    setRm,
    setEnv,
    withWorkingDirectory,
    withNetwork,
    withNetworkAlias,
    setLink,
    setExpose,
    setWaitingFor,
    run,

    -- * Following logs
    LogConsumer,
    consoleLogConsumer,
    withFollowLogs,

    -- * Network related functionality
    NetworkId,
    Network,
    NetworkRequest,
    networkId,
    networkRequest,
    createNetwork,
    fromExistingNetwork,
    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, stripPrefix)
import Data.Maybe (fromMaybe)
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.Environment (lookupEnv)
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 (..),
    WithoutReaper (..),
    consoleLogConsumer,
    docker,
    dockerFollowLogs,
    dockerWithStdin,
  )
import TestContainers.Docker.Network
  ( Network,
    NetworkId,
    NetworkRequest,
    createNetwork,
    fromExistingNetwork,
    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 -> Maybe Text
cpus :: Maybe Text,
    ContainerRequest -> Maybe Text
memory :: 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,
    ContainerRequest -> Maybe Text
workDirectory :: Maybe Text
  }

instance WithoutReaper ContainerRequest where
  withoutReaper :: ContainerRequest -> ContainerRequest
withoutReaper ContainerRequest
request = ContainerRequest
request {noReaper = True}

-- | 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 = Maybe [Text]
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 = Maybe (Either Network Text)
forall a. Maybe a
Nothing,
      $sel:networkAlias:ContainerRequest :: Maybe Text
networkAlias = Maybe Text
forall a. Maybe a
Nothing,
      $sel:memory:ContainerRequest :: Maybe Text
memory = Maybe Text
forall a. Maybe a
Nothing,
      $sel:cpus:ContainerRequest :: Maybe Text
cpus = Maybe Text
forall a. Maybe a
Nothing,
      $sel:links:ContainerRequest :: [Text]
links = [],
      $sel:rmOnExit:ContainerRequest :: Bool
rmOnExit = Bool
False,
      $sel:readiness:ContainerRequest :: WaitUntilReady
readiness = WaitUntilReady
forall a. Monoid a => a
mempty,
      $sel:labels:ContainerRequest :: [(Text, Text)]
labels = [(Text, Text)]
forall a. Monoid a => a
mempty,
      $sel:noReaper:ContainerRequest :: Bool
noReaper = Bool
False,
      $sel:followLogs:ContainerRequest :: Maybe LogConsumer
followLogs = Maybe LogConsumer
forall a. Maybe a
Nothing,
      $sel:workDirectory:ContainerRequest :: Maybe Text
workDirectory = Maybe Text
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 {naming = FixedName newName}

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

-- | Set the name randomly suffixed of a Docker container. This is equivalent to invoking
-- @docker run@ with the @--name@ parameter.
--
-- @since 0.5.0.0
setSuffixedName :: Text -> ContainerRequest -> ContainerRequest
setSuffixedName :: Text -> ContainerRequest -> ContainerRequest
setSuffixedName Text
preffix ContainerRequest
req =
  -- TODO error on empty Text
  ContainerRequest
req {naming = SuffixedName preffix}

-- | The command to execute inside the Docker container. This is the equivalent
-- of passing the command on the @docker run@ invocation.
--
-- @since 0.1.0.0
setCmd :: [Text] -> ContainerRequest -> ContainerRequest
setCmd :: [Text] -> ContainerRequest -> ContainerRequest
setCmd [Text]
newCmd ContainerRequest
req =
  ContainerRequest
req {cmd = Just newCmd}

-- | Set the memory limit of a Docker container. This is equivalent to
-- invoking @docker run@ with the @--memory@ parameter.
--
-- @since 0.5.1.0
setMemory :: Text -> ContainerRequest -> ContainerRequest
setMemory :: Text -> ContainerRequest -> ContainerRequest
setMemory Text
newMemory ContainerRequest
req =
  ContainerRequest
req {memory = Just newMemory}

-- | Set the cpus limit of a Docker container. This is equivalent to
-- invoking @docker run@ with the @--cpus@ parameter.
--
-- @since 0.5.1.0
setCpus :: Text -> ContainerRequest -> ContainerRequest
setCpus :: Text -> ContainerRequest -> ContainerRequest
setCpus Text
newCpus ContainerRequest
req =
  ContainerRequest
req {cpus = Just newCpus}

-- | 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 {volumeMounts = newVolumeMounts}

-- | Wether to remove the container once exited. This is equivalent to passing
-- @--rm@ to @docker run@. (default is `True`).
--
-- @since 0.1.0.0
setRm :: Bool -> ContainerRequest -> ContainerRequest
setRm :: Bool -> ContainerRequest -> ContainerRequest
setRm Bool
newRm ContainerRequest
req =
  ContainerRequest
req {rmOnExit = newRm}

-- | Set the environment for the container. This is equivalent to passing @--env key=value@
-- to @docker run@.
--
-- @since 0.1.0.0
setEnv :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
setEnv :: [(Text, Text)] -> ContainerRequest -> ContainerRequest
setEnv [(Text, Text)]
newEnv ContainerRequest
req =
  ContainerRequest
req {env = newEnv}

-- | Sets the working directory inside the container.
--
-- @since 0.5.1.0
withWorkingDirectory :: Text -> ContainerRequest -> ContainerRequest
withWorkingDirectory :: Text -> ContainerRequest -> ContainerRequest
withWorkingDirectory Text
workdir ContainerRequest
request =
  ContainerRequest
request {workDirectory = Just workdir}

-- | 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 {network = Just (Left 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 {networkAlias = Just 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 {labels = xs}

-- | Set link on the container. This is equivalent to passing @--link other_container@
-- to @docker run@.
--
-- @since 0.1.0.0
setLink :: [ContainerId] -> ContainerRequest -> ContainerRequest
setLink :: [Text] -> ContainerRequest -> ContainerRequest
setLink [Text]
newLink ContainerRequest
req =
  ContainerRequest
req {links = 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 {followLogs = Just logConsumer}

-- | Defintion of a 'Port'. Allows for specifying ports using various protocols. Due to the
-- 'Num' and 'IsString' instance allows for convenient Haskell literals.
--
-- >>> "80" :: Port
-- 80/tcp
--
-- >>> "80/tcp" :: Port
-- 80/tcp
--
-- >>> 80 :: Port
-- 80/tcp
--
-- >>> "90/udp" :: Port
-- 90/udp
data Port = Port
  { Port -> Int
port :: Int,
    Port -> Text
protocol :: Text
  }
  deriving stock (Port -> Port -> Bool
(Port -> Port -> Bool) -> (Port -> Port -> Bool) -> Eq Port
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Port -> Port -> Bool
== :: Port -> Port -> Bool
$c/= :: Port -> Port -> Bool
/= :: Port -> Port -> Bool
Eq, Eq Port
Eq Port =>
(Port -> Port -> Ordering)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Bool)
-> (Port -> Port -> Port)
-> (Port -> Port -> Port)
-> Ord 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
$ccompare :: Port -> Port -> Ordering
compare :: Port -> Port -> Ordering
$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
>= :: Port -> Port -> Bool
$cmax :: Port -> Port -> Port
max :: Port -> Port -> Port
$cmin :: Port -> Port -> Port
min :: Port -> Port -> Port
Ord)

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

-- @since 0.5.0.0
instance Show Port where
  show :: Port -> [Char]
show Port {Int
$sel:port:Port :: Port -> Int
port :: Int
port, Text
$sel:protocol:Port :: Port -> Text
protocol :: Text
protocol} =
    Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
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 = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x, $sel:protocol:Port :: Text
protocol = Text
defaultProtocol}
  + :: Port -> Port -> Port
(+) = [Char] -> Port -> Port -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"not implemented"
  * :: Port -> Port -> Port
(*) = [Char] -> Port -> Port -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"not implemented"
  abs :: Port -> Port
abs = [Char] -> Port -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"not implemented"
  signum :: Port -> Port
signum = [Char] -> Port -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"not implemented"
  negate :: Port -> Port
negate = [Char] -> Port -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"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 :: [Char] -> Port
fromString [Char]
input = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"/" ([Char] -> Text
pack [Char]
input) of
    [Text
numberish]
      | Right (Int
port, Text
"") <- Reader Int
forall a. Integral a => Reader a
decimal Text
numberish ->
          Port {Int
$sel:port:Port :: Int
port :: Int
port, $sel:protocol:Port :: Text
protocol = Text
defaultProtocol}
    [Text
numberish, Text
protocol]
      | Right (Int
port, Text
"") <- Reader Int
forall a. Integral a => Reader a
decimal Text
numberish ->
          Port {Int
$sel:port:Port :: Int
port :: Int
port, Text
$sel:protocol:Port :: Text
protocol :: Text
protocol}
    [Text]
_ ->
      [Char] -> Port
forall a. HasCallStack => [Char] -> a
Prelude.error ([Char]
"invalid port literal: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
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 {exposedPorts = newExpose}

-- | Set the waiting strategy on the container. Depending on a Docker container
-- it can take some time until the provided service is ready. You will want to
-- use to `setWaitingFor` to block until the container is ready to use.
--
-- @since 0.1.0.0
setWaitingFor :: WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor :: WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor WaitUntilReady
newWaitingFor ContainerRequest
req =
  ContainerRequest
req {readiness = newWaitingFor}

-- | Runs a Docker container from an `Image` and `ContainerRequest`. A finalizer
-- is registered so that the container is aways stopped when it goes out of scope.
-- This function is essentially @docker run@.
--
-- @since 0.1.0.0
run :: ContainerRequest -> TestContainer Container
run :: ContainerRequest -> TestContainer Container
run ContainerRequest
request = do
  let ContainerRequest
        { ToImage
$sel:toImage:ContainerRequest :: ContainerRequest -> ToImage
toImage :: ToImage
toImage,
          NamingStrategy
$sel:naming:ContainerRequest :: ContainerRequest -> NamingStrategy
naming :: NamingStrategy
naming,
          Maybe [Text]
$sel:cmd:ContainerRequest :: ContainerRequest -> Maybe [Text]
cmd :: Maybe [Text]
cmd,
          [(Text, Text)]
$sel:env:ContainerRequest :: ContainerRequest -> [(Text, Text)]
env :: [(Text, Text)]
env,
          [Port]
$sel:exposedPorts:ContainerRequest :: ContainerRequest -> [Port]
exposedPorts :: [Port]
exposedPorts,
          [(Text, Text)]
$sel:volumeMounts:ContainerRequest :: ContainerRequest -> [(Text, Text)]
volumeMounts :: [(Text, Text)]
volumeMounts,
          Maybe (Either Network Text)
$sel:network:ContainerRequest :: ContainerRequest -> Maybe (Either Network Text)
network :: Maybe (Either Network Text)
network,
          Maybe Text
$sel:networkAlias:ContainerRequest :: ContainerRequest -> Maybe Text
networkAlias :: Maybe Text
networkAlias,
          Maybe Text
$sel:memory:ContainerRequest :: ContainerRequest -> Maybe Text
memory :: Maybe Text
memory,
          Maybe Text
$sel:cpus:ContainerRequest :: ContainerRequest -> Maybe Text
cpus :: Maybe Text
cpus,
          [Text]
$sel:links:ContainerRequest :: ContainerRequest -> [Text]
links :: [Text]
links,
          Bool
$sel:rmOnExit:ContainerRequest :: ContainerRequest -> Bool
rmOnExit :: Bool
rmOnExit,
          WaitUntilReady
$sel:readiness:ContainerRequest :: ContainerRequest -> WaitUntilReady
readiness :: WaitUntilReady
readiness,
          [(Text, Text)]
$sel:labels:ContainerRequest :: ContainerRequest -> [(Text, Text)]
labels :: [(Text, Text)]
labels,
          Bool
$sel:noReaper:ContainerRequest :: ContainerRequest -> Bool
noReaper :: Bool
noReaper,
          Maybe LogConsumer
$sel:followLogs:ContainerRequest :: ContainerRequest -> Maybe LogConsumer
followLogs :: Maybe LogConsumer
followLogs,
          Maybe Text
$sel:workDirectory:ContainerRequest :: ContainerRequest -> Maybe Text
workDirectory :: Maybe Text
workDirectory
        } = ContainerRequest
request

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

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

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

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

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

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

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

      -- Careful, this is really meant to be lazy
      ~InspectOutput
inspectOutput =
        IO InspectOutput -> InspectOutput
forall a. IO a -> a
unsafePerformIO (IO InspectOutput -> InspectOutput)
-> IO InspectOutput -> InspectOutput
forall a b. (a -> b) -> a -> b
$
          Tracer -> Text -> IO InspectOutput
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 <- IO () -> TestContainer ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

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

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

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

  Container -> TestContainer Container
forall a. a -> TestContainer a
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
  [Char]
dockerSocketLocation <-
    IO [Char] -> TestContainer [Char]
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> TestContainer [Char])
-> IO [Char] -> TestContainer [Char]
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"DOCKER_HOST"
        IO (Maybe [Char])
-> (Maybe [Char] -> Maybe [Char]) -> IO (Maybe [Char])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe [Char] -> ([Char] -> Maybe [Char]) -> Maybe [Char]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Char]
"unix://")
        IO (Maybe [Char]) -> (Maybe [Char] -> [Char]) -> IO [Char]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"/var/run/docker.sock"
  Container
ryukContainer <-
    ContainerRequest -> TestContainer Container
run (ContainerRequest -> TestContainer Container)
-> ContainerRequest -> TestContainer Container
forall a b. (a -> b) -> a -> b
$
      ToImage -> ContainerRequest
containerRequest (Text -> ToImage
fromTag Text
ryukImageTag)
        ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
&
        -- Ryuk destroys itself once it reaped the resources,
        -- no need to register itself with itself.
        ContainerRequest -> ContainerRequest
forall request. WithoutReaper request => request -> request
withoutReaper
        ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& [(Text, Text)] -> ContainerRequest -> ContainerRequest
setVolumeMounts [([Char] -> Text
pack [Char]
dockerSocketLocation, Text
"/var/run/docker.sock")]
        ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& [Port] -> ContainerRequest -> ContainerRequest
setExpose [Port
forall a. Num a => a
ryukPort]
        ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
forall a b. a -> (a -> b) -> b
& WaitUntilReady -> ContainerRequest -> ContainerRequest
setWaitingFor (Port -> WaitUntilReady
waitUntilMappedPortReachable Port
forall a. Num a => a
ryukPort)
        ContainerRequest
-> (ContainerRequest -> ContainerRequest) -> ContainerRequest
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 Port
forall a. Num a => a
ryukPort

  Text -> Int -> TestContainer Reaper
forall (m :: * -> *). MonadResource m => Text -> Int -> m Reaper
newRyukReaper Text
ryukContainerAddress Int
ryukContainerPort

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

  TestContainer (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> TestContainer ())
-> ((Handle, Handle, Handle, ProcessHandle) -> TestContainer a)
-> TestContainer a
forall (m :: * -> *) a c b.
(HasCallStack, 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 (((Handle, Handle, Handle, ProcessHandle) -> TestContainer a)
 -> TestContainer a)
-> ((Handle, Handle, Handle, ProcessHandle) -> TestContainer a)
-> TestContainer a
forall a b. (a -> b) -> a -> b
$ \(Handle
stdin, Handle
stdout, Handle
stderr, ProcessHandle
_handle) -> do
    -- No need to keep it around...
    IO () -> TestContainer ()
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TestContainer ()) -> IO () -> TestContainer ()
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
  ToImage -> TestContainer ToImage
forall a. a -> TestContainer a
forall (m :: * -> *) a. Monad m => a -> m a
return (ToImage -> TestContainer ToImage)
-> ToImage -> TestContainer ToImage
forall a b. (a -> b) -> a -> b
$
    ToImage
toImage
      { runToImage = pure 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. This runs @docker pull --quiet <tag>@ to obtain an image id.
--
-- @since 0.1.0.0
fromTag :: ImageTag -> ToImage
fromTag :: Text -> ToImage
fromTag Text
tag = TestContainer Image -> ToImage
defaultToImage (TestContainer Image -> ToImage) -> TestContainer Image -> ToImage
forall a b. (a -> b) -> a -> b
$ do
  Tracer
tracer <- TestContainer Tracer
forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  [Char]
output <- Tracer -> [Text] -> TestContainer [Char]
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m [Char]
docker Tracer
tracer [Text
"pull", Text
"--quiet", Text
tag]
  Image -> TestContainer Image
forall a. a -> TestContainer a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> TestContainer Image) -> Image -> TestContainer Image
forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip ([Char] -> Text
pack [Char]
output)
      }

-- | Get an `Image` from an image id. This doesn't run @docker pull@ or any other Docker command
-- on construction.
--
-- @since 0.5.1.0
fromImageId :: Text -> ToImage
fromImageId :: Text -> ToImage
fromImageId Text
imageId =
  TestContainer Image -> ToImage
defaultToImage (TestContainer Image -> ToImage) -> TestContainer Image -> ToImage
forall a b. (a -> b) -> a -> b
$
    Image -> TestContainer Image
forall a. a -> TestContainer a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Image {$sel:tag:Image :: Text
tag = Text
imageId}

-- | 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 :: [Char] -> Maybe [Char] -> ToImage
fromBuildContext [Char]
path Maybe [Char]
mdockerfile = TestContainer Image -> ToImage
defaultToImage (TestContainer Image -> ToImage) -> TestContainer Image -> ToImage
forall a b. (a -> b) -> a -> b
$ do
  let args :: [Text]
args
        | Just [Char]
dockerfile <- Maybe [Char]
mdockerfile =
            [Text
"build", Text
"--quiet", Text
"--file", [Char] -> Text
pack [Char]
dockerfile, [Char] -> Text
pack [Char]
path]
        | Bool
otherwise =
            [Text
"build", Text
"--quiet", [Char] -> Text
pack [Char]
path]
  Tracer
tracer <- TestContainer Tracer
forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  [Char]
output <- Tracer -> [Text] -> TestContainer [Char]
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m [Char]
docker Tracer
tracer [Text]
args
  Image -> TestContainer Image
forall a. a -> TestContainer a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> TestContainer Image) -> Image -> TestContainer Image
forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip ([Char] -> Text
pack [Char]
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 (TestContainer Image -> ToImage) -> TestContainer Image -> ToImage
forall a b. (a -> b) -> a -> b
$ do
  Tracer
tracer <- TestContainer Tracer
forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  [Char]
output <- Tracer -> [Text] -> Text -> TestContainer [Char]
forall (m :: * -> *).
MonadIO m =>
Tracer -> [Text] -> Text -> m [Char]
dockerWithStdin Tracer
tracer [Text
"build", Text
"--quiet", Text
"-"] Text
dockerfile
  Image -> TestContainer Image
forall a. a -> TestContainer a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image -> TestContainer Image) -> Image -> TestContainer Image
forall a b. (a -> b) -> a -> b
$
    Image
      { $sel:tag:Image :: Text
tag = Text -> Text
strip ([Char] -> Text
pack [Char]
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 Container -> TestContainer ()
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
(UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool)
-> (UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool)
-> Eq UnexpectedEndOfPipe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
$c/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
Eq, Int -> UnexpectedEndOfPipe -> ShowS
[UnexpectedEndOfPipe] -> ShowS
UnexpectedEndOfPipe -> [Char]
(Int -> UnexpectedEndOfPipe -> ShowS)
-> (UnexpectedEndOfPipe -> [Char])
-> ([UnexpectedEndOfPipe] -> ShowS)
-> Show UnexpectedEndOfPipe
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnexpectedEndOfPipe -> ShowS
showsPrec :: Int -> UnexpectedEndOfPipe -> ShowS
$cshow :: UnexpectedEndOfPipe -> [Char]
show :: UnexpectedEndOfPipe -> [Char]
$cshowList :: [UnexpectedEndOfPipe] -> ShowS
showList :: [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
(TimeoutException -> TimeoutException -> Bool)
-> (TimeoutException -> TimeoutException -> Bool)
-> Eq TimeoutException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeoutException -> TimeoutException -> Bool
== :: TimeoutException -> TimeoutException -> Bool
$c/= :: TimeoutException -> TimeoutException -> Bool
/= :: TimeoutException -> TimeoutException -> Bool
Eq, Int -> TimeoutException -> ShowS
[TimeoutException] -> ShowS
TimeoutException -> [Char]
(Int -> TimeoutException -> ShowS)
-> (TimeoutException -> [Char])
-> ([TimeoutException] -> ShowS)
-> Show TimeoutException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeoutException -> ShowS
showsPrec :: Int -> TimeoutException -> ShowS
$cshow :: TimeoutException -> [Char]
show :: TimeoutException -> [Char]
$cshowList :: [TimeoutException] -> ShowS
showList :: [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
(InvalidStateException -> InvalidStateException -> Bool)
-> (InvalidStateException -> InvalidStateException -> Bool)
-> Eq InvalidStateException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InvalidStateException -> InvalidStateException -> Bool
== :: InvalidStateException -> InvalidStateException -> Bool
$c/= :: InvalidStateException -> InvalidStateException -> Bool
/= :: InvalidStateException -> InvalidStateException -> Bool
Eq, Int -> InvalidStateException -> ShowS
[InvalidStateException] -> ShowS
InvalidStateException -> [Char]
(Int -> InvalidStateException -> ShowS)
-> (InvalidStateException -> [Char])
-> ([InvalidStateException] -> ShowS)
-> Show InvalidStateException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InvalidStateException -> ShowS
showsPrec :: Int -> InvalidStateException -> ShowS
$cshow :: InvalidStateException -> [Char]
show :: InvalidStateException -> [Char]
$cshowList :: [InvalidStateException] -> ShowS
showList :: [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 ((Container -> TestContainer ()) -> WaitUntilReady)
-> (Container -> TestContainer ()) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Container {Text
$sel:id:Container :: Container -> Text
id :: Text
id} -> do
  let wait :: TestContainer ()
wait = do
        Config {Tracer
configTracer :: Config -> Tracer
configTracer :: Tracer
configTracer} <-
          TestContainer Config
forall r (m :: * -> *). MonadReader r m => m r
ask
        InspectOutput
inspectOutput <-
          Tracer -> Text -> TestContainer 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 () -> TestContainer ()
forall a. a -> TestContainer a
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!
                InvalidStateException -> TestContainer ()
forall e a. (HasCallStack, Exception e) => e -> TestContainer a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM InvalidStateException {Text
$sel:id:InvalidStateException :: Text
id :: Text
id}
              Status
Dead ->
                -- Once dead, state won't change!
                InvalidStateException -> TestContainer ()
forall e a. (HasCallStack, Exception e) => e -> TestContainer a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM InvalidStateException {Text
$sel:id:InvalidStateException :: Text
id :: Text
id}
              Status
_ -> do
                IO () -> TestContainer ()
forall a. IO a -> TestContainer a
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 Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
Exited Bool -> Bool -> Bool
&& State -> Maybe Int
stateExitCode State
state Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
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 -> [Char] -> [Int] -> WaitUntilReady
waitForHttp Port
port [Char]
path [Int]
acceptableStatusCodes = (Container -> TestContainer ()) -> WaitUntilReady
WaitReady ((Container -> TestContainer ()) -> WaitUntilReady)
-> (Container -> TestContainer ()) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Container
container -> do
  Config {Tracer
configTracer :: Config -> Tracer
configTracer :: Tracer
configTracer} <- TestContainer Config
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 =
        IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings) m Manager -> (Manager -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> m ()
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 = encodeUtf8 endpointHost,
                  port = endpointPort,
                  path = encodeUtf8 (pack path)
                }
        Either HttpException Int
result <-
          m Int -> m (Either HttpException Int)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m Int -> m (Either HttpException Int))
-> m Int -> m (Either HttpException Int)
forall a b. (a -> b) -> a -> b
$
            Status -> Int
statusCode (Status -> Int) -> (Response () -> Status) -> Response () -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response () -> Status
forall body. Response body -> Status
responseStatus (Response () -> Int) -> m (Response ()) -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Response ()) -> m (Response ())
forall a. IO a -> m a
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
            Tracer -> Trace -> m ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
              Tracer
configTracer
              (Text -> Int -> Either [Char] Int -> Trace
TraceHttpCall Text
endpointHost Int
endpointPort (Int -> Either [Char] Int
forall a b. b -> Either a b
Right Int
code))
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
code Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
acceptableStatusCodes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
500000)
              Manager -> m ()
forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry Manager
manager
          Left (HttpException
exception :: HttpException) -> do
            Tracer -> Trace -> m ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
              Tracer
configTracer
              (Text -> Int -> Either [Char] Int -> Trace
TraceHttpCall Text
endpointHost Int
endpointPort ([Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char] -> Either [Char] Int) -> [Char] -> Either [Char] Int
forall a b. (a -> b) -> a -> b
$ HttpException -> [Char]
forall a. Show a => a -> [Char]
show HttpException
exception))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
500000)
            Manager -> m ()
forall (m :: * -> *). (MonadIO m, MonadCatch m) => Manager -> m ()
retry Manager
manager

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

    let resolve :: [Char] -> a -> IO AddrInfo
resolve [Char]
endpointHost a
endpointPort = do
          let hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints {Socket.addrSocketType = Socket.Stream}
          [AddrInfo] -> AddrInfo
forall a. HasCallStack => [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
endpointHost) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (a -> [Char]
forall a. Show a => a -> [Char]
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)
          Socket -> IO Socket
forall a. a -> IO a
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 <- IO Socket -> IO (Either IOException Socket)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try ([Char] -> Int -> IO AddrInfo
forall {a}. Show a => [Char] -> a -> IO AddrInfo
resolve (Text -> [Char]
unpack Text
endpointHost) Int
endpointPort IO AddrInfo -> (AddrInfo -> IO Socket) -> IO Socket
forall a b. IO a -> (a -> IO b) -> IO b
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
              Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
configTracer (Text -> Int -> Maybe IOException -> Trace
TraceOpenSocket Text
endpointHost Int
endpointPort Maybe IOException
forall a. Maybe a
Nothing)
              Socket -> IO ()
Socket.close Socket
socket
              () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Left (IOException
exception :: IOException) -> do
              Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace
                Tracer
configTracer
                (Text -> Int -> Maybe IOException -> Trace
TraceOpenSocket Text
endpointHost Int
endpointPort (IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
exception))
              Int -> IO ()
threadDelay Int
500000
              IO ()
wait

    IO () -> TestContainer ()
forall a. IO a -> TestContainer a
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 ((Container -> TestContainer ()) -> WaitUntilReady)
-> (Container -> TestContainer ()) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Container
container ->
  Container
-> (Handle -> Handle -> TestContainer ()) -> TestContainer ()
forall a.
Container
-> (Handle -> Handle -> TestContainer a) -> TestContainer a
withLogs Container
container ((Handle -> Handle -> TestContainer ()) -> TestContainer ())
-> (Handle -> Handle -> TestContainer ()) -> TestContainer ()
forall a b. (a -> b) -> a -> b
$ \Handle
stdout Handle
stderr ->
    IO () -> TestContainer ()
forall a. IO a -> TestContainer a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TestContainer ()) -> IO () -> TestContainer ()
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 ((Container -> Handle -> Handle -> IO ()) -> WaitUntilReady)
-> (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Container {Text
$sel:id:Container :: Container -> Text
id :: 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!
        (ByteString -> Text) -> [ByteString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
          (OnDecodeError -> ByteString -> Text
LazyText.decodeUtf8With OnDecodeError
lenientDecode)
          (ByteString -> [ByteString]
LazyByteString.lines ByteString
logContent)

  case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Text -> Bool
matches [Text]
logLines of
    Just Text
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Text
Nothing -> UnexpectedEndOfPipe -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (UnexpectedEndOfPipe -> IO ()) -> UnexpectedEndOfPipe -> IO ()
forall a b. (a -> b) -> a -> b
$ UnexpectedEndOfPipe {Text
$sel:id:UnexpectedEndOfPipe :: Text
id :: 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
$sel:id:Container :: Container -> Text
id :: Text
id} WaitUntilReady
input = do
  Config {Maybe Int
configDefaultWaitTimeout :: Maybe Int
configDefaultWaitTimeout :: Config -> Maybe Int
configDefaultWaitTimeout} <- TestContainer Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  WaitUntilReady -> TestContainer ()
interpreter (WaitUntilReady -> TestContainer ())
-> WaitUntilReady -> TestContainer ()
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 a. TestContainer a -> IO a) -> IO ()) -> TestContainer ()
forall b.
((forall a. TestContainer a -> IO a) -> IO b) -> TestContainer b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. TestContainer a -> IO a) -> IO ())
 -> TestContainer ())
-> ((forall a. TestContainer a -> IO a) -> IO ())
-> TestContainer ()
forall a b. (a -> b) -> a -> b
$ \forall a. TestContainer a -> IO a
runInIO -> do
            Maybe ()
result <-
              Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
seconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000) (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
                TestContainer () -> IO ()
forall a. TestContainer a -> IO a
runInIO (WaitUntilReady -> TestContainer ()
interpreter WaitUntilReady
rest)
            case Maybe ()
result of
              Maybe ()
Nothing ->
                TimeoutException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (TimeoutException -> IO ()) -> TimeoutException -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeoutException {Text
$sel:id:TimeoutException :: Text
id :: Text
id}
              Just {} ->
                () -> IO ()
forall a. a -> IO a
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
(Image -> Image -> Bool) -> (Image -> Image -> Bool) -> Eq Image
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Image -> Image -> Bool
== :: Image -> Image -> Bool
$c/= :: Image -> Image -> Bool
/= :: Image -> Image -> Bool
Eq, Int -> Image -> ShowS
[Image] -> ShowS
Image -> [Char]
(Int -> Image -> ShowS)
-> (Image -> [Char]) -> ([Image] -> ShowS) -> Show Image
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Image -> ShowS
showsPrec :: Int -> Image -> ShowS
$cshow :: Image -> [Char]
show :: Image -> [Char]
$cshowList :: [Image] -> ShowS
showList :: [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
$sel:tag:Image :: Image -> Text
tag :: 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
$sel:id:Container :: Container -> Text
id :: 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
$sel:image:Container :: Container -> Image
image :: 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
$sel:releaseKey:Container :: Container -> ReleaseKey
releaseKey :: 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
$sel:id:Container :: Container -> Text
id :: Text
id, InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput :: InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    InspectOutput
-> Optic' An_AffineTraversal '[] InspectOutput Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
      AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"IPAddress"
      AffineTraversal' InspectOutput InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' An_AffineTraversal '[] InspectOutput Text
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
% Optic A_Prism '[] InspectOutput InspectOutput Text Text
forall t. AsValue t => Prism' t Text
Optics._String of
    Maybe Text
Nothing ->
      DockerException -> Text
forall a e. Exception e => e -> a
throw (DockerException -> Text) -> DockerException -> Text
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
$sel:id:Container :: Container -> Text
id :: Text
id, InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput :: InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    InspectOutput
-> Optic' An_AffineFold '[] InspectOutput Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic' A_Traversal '[Key, Int] InspectOutput Text
-> Optic' An_AffineFold '[] InspectOutput Text
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
      ( Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
          AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Networks"
          AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
forall t. AsValue t => IxTraversal' Key t InspectOutput
Optics.members
          Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Aliases"
          Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
-> Optic
     A_Traversal
     '[Key, Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Optic
  A_Traversal
  '[Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
forall t. AsValue t => IxTraversal' Int t InspectOutput
Optics.values
          Optic
  A_Traversal
  '[Key, Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' A_Traversal '[Key, Int] InspectOutput Text
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
% Optic A_Prism '[] InspectOutput InspectOutput Text Text
forall t. AsValue t => Prism' t Text
Optics._String
      ) of
    Maybe Text
Nothing ->
      DockerException -> Text
forall a e. Exception e => e -> a
throw (DockerException -> Text) -> DockerException -> Text
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
$sel:id:Container :: Container -> Text
id :: Text
id, InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput :: InspectOutput
inspectOutput} =
  case InspectOutput
inspectOutput
    InspectOutput
-> Optic' An_AffineFold '[] InspectOutput Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic' A_Traversal '[Key] InspectOutput Text
-> Optic' An_AffineFold '[] InspectOutput Text
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
      ( Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
          AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Networks"
          AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
forall t. AsValue t => IxTraversal' Key t InspectOutput
Optics.members
          Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Key]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Gateway"
          Optic
  A_Traversal
  '[Key]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' A_Traversal '[Key] InspectOutput Text
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
% Optic A_Prism '[] InspectOutput InspectOutput Text Text
forall t. AsValue t => Prism' t Text
Optics._String
      ) of
    Maybe Text
Nothing ->
      DockerException -> Text
forall a e. Exception e => e -> a
throw (DockerException -> Text) -> DockerException -> Text
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
$sel:id:Container :: Container -> Text
id :: Text
id, InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput :: InspectOutput
inspectOutput} Port {Int
$sel:port:Port :: Port -> Int
port :: Int
port, Text
$sel:protocol:Port :: Port -> Text
protocol :: 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 = [Char] -> s
forall a. IsString a => [Char] -> a
fromString ([Char] -> s) -> [Char] -> s
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
unpack Text
protocol
   in -- TODO be more mindful, make sure to grab the
      -- port from the right host address

      case InspectOutput
inspectOutput
        InspectOutput
-> Optic' An_AffineFold '[] InspectOutput Text -> Maybe Text
forall k s (is :: IxList) a.
Is k An_AffineFold =>
s -> Optic' k is s a -> Maybe a
^? Optic' A_Traversal '[Int] InspectOutput Text
-> Optic' An_AffineFold '[] InspectOutput Text
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> AffineFold s a
pre
          ( Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"NetworkSettings"
              AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"Ports"
              AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
forall s. IsString s => s
textPort
              AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Optic
  A_Traversal
  '[Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
forall t. AsValue t => IxTraversal' Int t InspectOutput
Optics.values
              Optic
  A_Traversal
  '[Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
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
% Key -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Key -> AffineTraversal' t InspectOutput
Optics.key Key
"HostPort"
              Optic
  A_Traversal
  '[Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' A_Traversal '[Int] InspectOutput Text
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
% Optic A_Prism '[] InspectOutput InspectOutput Text Text
forall t. AsValue t => Prism' t Text
Optics._String
          ) of
        Maybe Text
Nothing ->
          DockerException -> Int
forall a e. Exception e => e -> a
throw (DockerException -> Int) -> DockerException -> Int
forall a b. (a -> b) -> a -> b
$
            UnknownPortMapping
              { Text
id :: Text
id :: Text
id,
                port :: Text
port = Text
forall s. IsString s => s
textPort
              }
        Just Text
hostPort ->
          [Char] -> Int
forall a. Read a => [Char] -> a
read (Text -> [Char]
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
$sel:port:Port :: Port -> Int
port :: Int
port, Text
$sel:protocol:Port :: Port -> Text
protocol :: Text
protocol} =
  let inDocker :: Bool
inDocker = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO IO Bool
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
$sel:port:Port :: Int
port :: Int
port, Text
$sel:protocol:Port :: Text
protocol :: 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
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput :: InspectOutput
inspectOutput} =
  InspectOutput -> TestContainer InspectOutput
forall a. a -> TestContainer a
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
  [Char]
stdout <- Tracer -> [Text] -> m [Char]
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m [Char]
docker Tracer
tracer [Text
"inspect", Text
id]
  case ByteString -> Maybe [InspectOutput]
forall a. FromJSON a => ByteString -> Maybe a
decode' ([Char] -> ByteString
LazyByteString.pack [Char]
stdout) of
    Maybe [InspectOutput]
Nothing ->
      DockerException -> m InspectOutput
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (DockerException -> m InspectOutput)
-> DockerException -> m InspectOutput
forall a b. (a -> b) -> a -> b
$ InspectOutputInvalidJSON {Text
id :: Text
id :: Text
id}
    Just [] ->
      DockerException -> m InspectOutput
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (DockerException -> m InspectOutput)
-> DockerException -> m InspectOutput
forall a b. (a -> b) -> a -> b
$ InspectUnknownContainerId {Text
id :: Text
id :: Text
id}
    Just [InspectOutput
value] ->
      InspectOutput -> m InspectOutput
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InspectOutput
value
    Just [InspectOutput]
_ ->
      [Char] -> m InspectOutput
forall a. HasCallStack => [Char] -> a
Prelude.error [Char]
"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 :: Config -> Tracer
configTracer :: Tracer
configTracer} <- m Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  Tracer -> m Tracer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer
configTracer
{-# INLINE askTracer #-}

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

isDockerOnLinux :: TestContainer Bool
isDockerOnLinux :: TestContainer Bool
isDockerOnLinux =
  (Text
"linux" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==) (Text -> Bool) -> TestContainer Text -> TestContainer 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 = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
"/.dockerenv"