{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PatternSynonyms            #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE UndecidableInstances       #-}
module TestContainers.Docker
  (
    MonadDocker

  -- * Configuration

  , Config(..)
  , defaultDockerConfig
  , determineConfig

  -- * Exeuction tracing

  , Tracer
  , Trace(..)
  , newTracer
  , withTrace

  -- * Docker image

  , ImageTag

  , Image
  , imageTag

  -- * Docker container

  , ContainerId
  , Container

  , containerId
  , containerImage
  , containerIp
  , containerPort
  , containerReleaseKey

  -- * Referring to images

  , ToImage

  , fromTag
  , fromBuildContext
  , fromDockerfile

  , build

  -- * Exceptions

  , DockerException(..)

  -- * Running containers

  , ContainerRequest
  , containerRequest
  , setName
  , setCmd
  , setRm
  , setEnv
  , setLink
  , setExpose
  , setWaitingFor
  , run

  -- * Managing the container lifecycle

  , InspectOutput
  , inspect

  , stop
  , kill
  , rm
  , withLogs

  -- * Wait for containers to become ready
  , WaitUntilReady
  , waitUntilReady

  -- * Only block for defined amounts of time
  , TimeoutException(..)
  , waitUntilTimeout

  -- * Wait until a specific pattern appears in the logs
  , waitWithLogs
  , UnexpectedEndOfPipe(..)
  , Pipe(..)
  , waitForLogLine

  -- * Misc. Docker functions

  , dockerHostOs
  , isDockerOnLinux

  -- * Wait until a socket is reachable
  , waitUntilMappedPortReachable

  -- * Reexports for convenience
  , ResIO
  , runResourceT

  , (&)
  ) where

import           Control.Applicative          ((<|>))
import           Control.Concurrent           (threadDelay)
import           Control.Exception            (IOException, throw)
import           Control.Monad.Catch          (Exception, MonadCatch, MonadMask,
                                               MonadThrow, bracket, throwM, try)
import           Control.Monad.Fix            (mfix)
import           Control.Monad.IO.Class       (MonadIO (liftIO))
import           Control.Monad.IO.Unlift      (MonadUnliftIO (withRunInIO))
import           Control.Monad.Reader         (MonadReader (..), runReaderT)
import           Control.Monad.Trans.Resource (MonadResource (liftResourceT),
                                               ReleaseKey, ResIO, register,
                                               runResourceT)
import           Data.Aeson                   (Value, decode')
import qualified Data.Aeson.Optics            as Optics
import qualified Data.ByteString.Lazy.Char8   as LazyByteString
import           Data.Foldable                (traverse_)
import           Data.Function                ((&))
import           Data.List                    (find)
import           Data.Text                    (Text, pack, strip, unpack)
import           Data.Text.Encoding.Error     (lenientDecode)
import qualified Data.Text.Lazy               as LazyText
import qualified Data.Text.Lazy.Encoding      as LazyText
import           GHC.Stack                    (withFrozenCallStack)
import qualified Network.Socket               as Socket
import           Optics.Fold                  (pre)
import           Optics.Operators             ((^?))
import           Optics.Optic                 ((%))
import           Prelude                      hiding (error, id)
import qualified Prelude
import           System.Exit                  (ExitCode (..))
import           System.IO                    (Handle, hClose)
import           System.IO.Unsafe             (unsafePerformIO)
import qualified System.Process               as Process
import           System.Timeout               (timeout)


-- | Type representing various events during testcontainer execution.
data Trace
  -- | The low-level invocation of @docker@ command
  --
  -- @
  --   TraceDockerInvocation args stdin exitcode
  -- @
  = TraceDockerInvocation [Text] Text ExitCode -- docker [args] [stdin]
  -- | Line written to STDOUT by a Docker process.
  | TraceDockerStdout Text
  -- | Line written to STDERR by a Docker process.
  | TraceDockerStderr Text
  -- | Waiting for a container to become ready. Attached with the
  -- timeout to wait (in seconds).
  | TraceWaitUntilReady (Maybe Int)
  -- | Opening socket
  | TraceOpenSocket Text Int (Maybe IOException)


deriving stock instance Eq Trace
deriving stock instance Show Trace


-- | Traces execution within testcontainers library.
newtype Tracer = Tracer { Tracer -> Trace -> IO ()
unTracer :: Trace -> IO () }


deriving newtype instance Semigroup Tracer
deriving newtype instance Monoid Tracer


-- | Construct a new `Tracer` from a tracing function.
newTracer
  :: (Trace -> IO ())
  -> Tracer
newTracer :: (Trace -> IO ()) -> Tracer
newTracer Trace -> IO ()
action = Tracer :: (Trace -> IO ()) -> Tracer
Tracer
  {
    $sel:unTracer:Tracer :: Trace -> IO ()
unTracer = Trace -> IO ()
action
  }


withTrace :: MonadIO m => Tracer -> Trace -> m ()
withTrace :: Tracer -> Trace -> m ()
withTrace Tracer
tracer Trace
trace =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Tracer -> Trace -> IO ()
unTracer Tracer
tracer Trace
trace
{-# INLINE withTrace #-}


-- | Configuration for defaulting behavior.
--
-- @since 0.2.0.0
--
data Config = Config
  {
    -- | The number of seconds to maximally wait for a container to
    -- become ready. Default is `Just 60`.
    --
    -- @Nothing@ <=> waits indefinitely.
    Config -> Maybe Int
configDefaultWaitTimeout :: Maybe Int
    -- | Traces execution inside testcontainers library.
  , Config -> Tracer
configTracer             :: Tracer
  }


-- | Default configuration.
--
-- @since 0.2.0.0
--
defaultDockerConfig :: Config
defaultDockerConfig :: Config
defaultDockerConfig = Config :: Maybe Int -> Tracer -> Config
Config
  {
    $sel:configDefaultWaitTimeout:Config :: Maybe Int
configDefaultWaitTimeout = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
60
  , $sel:configTracer:Config :: Tracer
configTracer = Tracer
forall a. Monoid a => a
mempty
  }


-- | Autoselect the default configuration depending on wether you use Docker For
-- Mac or not.
determineConfig :: IO Config
determineConfig :: IO Config
determineConfig =
  Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
defaultDockerConfig


-- | Failing to interact with Docker results in this exception
-- being thrown.
--
-- @since 0.1.0.0
--
data DockerException
  = DockerException
    {
      -- | Exit code of the underlying Docker process.
      DockerException -> ExitCode
exitCode :: ExitCode
      -- | Arguments that were passed to Docker.
    , DockerException -> [Text]
args     :: [Text]
      -- | Docker's STDERR output.
    , DockerException -> Text
stderr   :: Text
    }
  | InspectUnknownContainerId { DockerException -> Text
id :: ContainerId }
  | InspectOutputInvalidJSON  { id :: ContainerId }
  | InspectOutputUnexpected   { id :: ContainerId }
  | UnknownPortMapping
    {
      -- | Id of the `Container` that we tried to lookup the
      -- port mapping.
      id   :: ContainerId
      -- | Textual representation of port mapping we were
      -- trying to look up.
    , DockerException -> Text
port :: Text
    }
  deriving (DockerException -> DockerException -> Bool
(DockerException -> DockerException -> Bool)
-> (DockerException -> DockerException -> Bool)
-> Eq DockerException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DockerException -> DockerException -> Bool
$c/= :: DockerException -> DockerException -> Bool
== :: DockerException -> DockerException -> Bool
$c== :: DockerException -> DockerException -> Bool
Eq, Int -> DockerException -> ShowS
[DockerException] -> ShowS
DockerException -> String
(Int -> DockerException -> ShowS)
-> (DockerException -> String)
-> ([DockerException] -> ShowS)
-> Show DockerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DockerException] -> ShowS
$cshowList :: [DockerException] -> ShowS
show :: DockerException -> String
$cshow :: DockerException -> String
showsPrec :: Int -> DockerException -> ShowS
$cshowsPrec :: Int -> DockerException -> ShowS
Show)


instance Exception DockerException


-- | Docker related functionality is parameterized over this `Monad`.
--
-- @since 0.1.0.0
--
type MonadDocker m =
  (MonadIO m, MonadMask m, MonadThrow m, MonadCatch m, MonadResource m, MonadReader Config m)


-- | Parameters for a running a Docker container.
--
-- @since 0.1.0.0
--
data ContainerRequest = ContainerRequest
  {
    ContainerRequest -> ToImage
toImage      :: ToImage
  , ContainerRequest -> Maybe [Text]
cmd          :: Maybe [Text]
  , ContainerRequest -> [(Text, Text)]
env          :: [(Text, Text)]
  , ContainerRequest -> [Int]
exposedPorts :: [Int]
  , ContainerRequest -> [(Text, Text)]
volumeMounts :: [(Text, Text)]
  , ContainerRequest -> [Text]
links        :: [ContainerId]
  , ContainerRequest -> Maybe Text
name         :: Maybe Text
  , ContainerRequest -> Bool
rmOnExit     :: Bool
  , ContainerRequest -> Maybe WaitUntilReady
readiness    :: Maybe WaitUntilReady
  }


-- | Default `ContainerRequest`. Used as base for every Docker container.
--
-- @since 0.1.0.0
--
containerRequest :: ToImage -> ContainerRequest
containerRequest :: ToImage -> ContainerRequest
containerRequest ToImage
image = ContainerRequest :: ToImage
-> Maybe [Text]
-> [(Text, Text)]
-> [Int]
-> [(Text, Text)]
-> [Text]
-> Maybe Text
-> Bool
-> Maybe WaitUntilReady
-> ContainerRequest
ContainerRequest
  {
    $sel:toImage:ContainerRequest :: ToImage
toImage      = ToImage
image
  , $sel:name:ContainerRequest :: Maybe Text
name         = Maybe Text
forall a. Maybe a
Nothing
  , $sel:cmd:ContainerRequest :: Maybe [Text]
cmd          = Maybe [Text]
forall a. Maybe a
Nothing
  , $sel:env:ContainerRequest :: [(Text, Text)]
env          = []
  , $sel:exposedPorts:ContainerRequest :: [Int]
exposedPorts = []
  , $sel:volumeMounts:ContainerRequest :: [(Text, Text)]
volumeMounts = []
  , $sel:links:ContainerRequest :: [Text]
links        = []
  , $sel:rmOnExit:ContainerRequest :: Bool
rmOnExit     = Bool
True
  , $sel:readiness:ContainerRequest :: Maybe WaitUntilReady
readiness    = Maybe WaitUntilReady
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
newName ContainerRequest
req =
  -- TODO error on empty Text
  ContainerRequest
req { $sel:name:ContainerRequest :: Maybe Text
name = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
newName }


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


-- | 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 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 }


-- | Set exposed ports on the container. This is equivalent to setting @--publish $PORT@ to
-- @docker run@. Docker assigns a random port for the host port. You will have to use `containerIp`
-- and `containerPort` to connect to the published port.
--
-- @
--   container <- `run` $ `containerRequest` `redis` & `setExpose` [ 6379 ]
--   let (redisHost, redisPort) = (`containerIp` container, `containerPort` container 6379)
--   print (redisHost, redisPort)
-- @
--
-- @since 0.1.0.0
--
setExpose :: [Int] -> ContainerRequest -> ContainerRequest
setExpose :: [Int] -> ContainerRequest -> ContainerRequest
setExpose [Int]
newExpose ContainerRequest
req =
  ContainerRequest
req { $sel:exposedPorts:ContainerRequest :: [Int]
exposedPorts = [Int]
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 :: Maybe WaitUntilReady
readiness = WaitUntilReady -> Maybe WaitUntilReady
forall a. a -> Maybe a
Just 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 :: MonadDocker m => ContainerRequest -> m Container
run :: ContainerRequest -> m Container
run ContainerRequest
request = do

  let
    ContainerRequest
      {
        ToImage
toImage :: ToImage
$sel:toImage:ContainerRequest :: ContainerRequest -> ToImage
toImage
      , Maybe Text
name :: Maybe Text
$sel:name:ContainerRequest :: ContainerRequest -> Maybe Text
name
      , Maybe [Text]
cmd :: Maybe [Text]
$sel:cmd:ContainerRequest :: ContainerRequest -> Maybe [Text]
cmd
      , [(Text, Text)]
env :: [(Text, Text)]
$sel:env:ContainerRequest :: ContainerRequest -> [(Text, Text)]
env
      , [Int]
exposedPorts :: [Int]
$sel:exposedPorts:ContainerRequest :: ContainerRequest -> [Int]
exposedPorts
      , [(Text, Text)]
volumeMounts :: [(Text, Text)]
$sel:volumeMounts:ContainerRequest :: ContainerRequest -> [(Text, Text)]
volumeMounts
      , [Text]
links :: [Text]
$sel:links:ContainerRequest :: ContainerRequest -> [Text]
links
      , Bool
rmOnExit :: Bool
$sel:rmOnExit:ContainerRequest :: ContainerRequest -> Bool
rmOnExit
      , Maybe WaitUntilReady
readiness :: Maybe WaitUntilReady
$sel:readiness:ContainerRequest :: ContainerRequest -> Maybe WaitUntilReady
readiness
      } = ContainerRequest
request

  image :: Image
image@Image{ Text
$sel:tag:Image :: Image -> Text
tag :: Text
tag } <- ToImage -> forall (m :: * -> *). MonadDocker m => m Image
runToImage ToImage
toImage

  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
"--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", String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
port)] | Int
port <- [Int]
exposedPorts ] [[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
tag ] ] [[Text]] -> [[Text]] -> [[Text]]
forall a. [a] -> [a] -> [a]
++
      [ [Text]
command | Just [Text]
command <- [Maybe [Text]
cmd] ]

  config :: Config
config@Config { Tracer
configTracer :: Tracer
$sel:configTracer:Config :: Config -> Tracer
configTracer } <- m Config
forall r (m :: * -> *). MonadReader r m => m r
ask

  String
stdout <- Tracer -> [Text] -> m String
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 = 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

  Container
container <- ResourceT IO Container -> m Container
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ResourceT IO Container -> m Container)
-> ResourceT IO Container -> m Container
forall a b. (a -> b) -> a -> b
$ (Container -> ResourceT IO Container) -> ResourceT IO Container
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((Container -> ResourceT IO Container) -> ResourceT IO Container)
-> (Container -> ResourceT IO Container) -> ResourceT IO Container
forall a b. (a -> b) -> a -> b
$ \Container
container -> do
      -- Note: We have to tie the knot as the resulting container
      -- carries the release key as well.
      ReleaseKey
releaseKey <- IO () -> ResourceT IO ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
register (IO () -> ResourceT IO ReleaseKey)
-> IO () -> ResourceT IO ReleaseKey
forall a b. (a -> b) -> a -> b
$ ReaderT Config IO () -> Config -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ResourceT (ReaderT Config IO) () -> ReaderT Config IO ()
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (Container -> ResourceT (ReaderT Config IO) ()
forall (m :: * -> *). MonadDocker m => Container -> m ()
stop Container
container)) Config
config
      Container -> ResourceT IO Container
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Container -> ResourceT IO Container)
-> Container -> ResourceT IO Container
forall a b. (a -> b) -> a -> b
$ Container :: Text -> ReleaseKey -> Image -> Config -> InspectOutput -> 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
        }

  case Maybe WaitUntilReady
readiness of
    Just WaitUntilReady
wait ->
      Container -> WaitUntilReady -> m ()
forall (m :: * -> *).
MonadDocker m =>
Container -> WaitUntilReady -> m ()
waitUntilReady Container
container WaitUntilReady
wait
    Maybe WaitUntilReady
Nothing ->
      () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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


-- | Internal function that runs Docker. Takes care of throwing an exception
-- in case of failure.
--
-- @since 0.1.0.0
--
docker :: MonadIO m => Tracer -> [Text] -> m String
docker :: Tracer -> [Text] -> m String
docker Tracer
tracer [Text]
args =
  Tracer -> [Text] -> Text -> m String
forall (m :: * -> *).
MonadIO m =>
Tracer -> [Text] -> Text -> m String
dockerWithStdin Tracer
tracer [Text]
args Text
""


-- | Internal function that runs Docker. Takes care of throwing an exception
-- in case of failure.
--
-- @since 0.1.0.0
--
dockerWithStdin :: MonadIO m => Tracer -> [Text] -> Text -> m String
dockerWithStdin :: Tracer -> [Text] -> Text -> m String
dockerWithStdin Tracer
tracer [Text]
args Text
stdin = IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ do
  (ExitCode
exitCode, String
stdout, String
stderr) <- String -> [String] -> String -> IO (ExitCode, String, String)
Process.readProcessWithExitCode String
"docker"
    ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
args) (Text -> String
unpack Text
stdin)

  Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer ([Text] -> Text -> ExitCode -> Trace
TraceDockerInvocation [Text]
args Text
stdin ExitCode
exitCode)

  -- TODO output these concurrently with the process
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer (Trace -> IO ()) -> (String -> Trace) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Trace
TraceDockerStdout (Text -> Trace) -> (String -> Text) -> String -> Trace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> [String]
lines String
stdout)
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer (Trace -> IO ()) -> (String -> Trace) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Trace
TraceDockerStderr (Text -> Trace) -> (String -> Text) -> String -> Trace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> [String]
lines String
stderr)

  case ExitCode
exitCode of
    ExitCode
ExitSuccess -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stdout
    ExitCode
_ -> DockerException -> IO String
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (DockerException -> IO String) -> DockerException -> IO String
forall a b. (a -> b) -> a -> b
$ DockerException :: ExitCode -> [Text] -> Text -> DockerException
DockerException
      {
        ExitCode
exitCode :: ExitCode
$sel:exitCode:DockerException :: ExitCode
exitCode, [Text]
args :: [Text]
$sel:args:DockerException :: [Text]
args
      , $sel:stderr:DockerException :: Text
stderr = String -> Text
pack String
stderr
      }


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


-- | Stops a Docker container. `stop` is essentially @docker stop@.
--
-- @since 0.1.0.0
--
stop :: MonadDocker m => Container -> m ()
stop :: Container -> m ()
stop Container { Text
id :: Text
$sel:id:Container :: Container -> Text
id } = do
  Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
_ <- Tracer -> [Text] -> m String
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [ Text
"stop", Text
id ]
  () -> m ()
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 :: MonadDocker m => Container -> m ()
rm :: Container -> m ()
rm Container { Text
id :: Text
$sel:id:Container :: Container -> Text
id } = do
  Tracer
tracer <- m Tracer
forall (m :: * -> *). MonadReader Config m => m Tracer
askTracer
  String
_ <- Tracer -> [Text] -> m String
forall (m :: * -> *). MonadIO m => Tracer -> [Text] -> m String
docker Tracer
tracer [ Text
"rm", Text
"-f", Text
"-v", Text
id ]
  () -> m ()
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 :: forall m a . MonadDocker m => Container -> (Handle -> Handle -> m a) -> m a
withLogs :: Container -> (Handle -> Handle -> m a) -> m a
withLogs Container { Text
id :: Text
$sel:id:Container :: Container -> Text
id } Handle -> Handle -> m a
logger = do

  let
    acquire :: m (Handle, Handle, Handle, Process.ProcessHandle)
    acquire :: m (Handle, Handle, Handle, ProcessHandle)
acquire =
      IO (Handle, Handle, Handle, ProcessHandle)
-> m (Handle, Handle, Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Handle, Handle, Handle, ProcessHandle)
 -> m (Handle, Handle, Handle, ProcessHandle))
-> IO (Handle, Handle, Handle, ProcessHandle)
-> m (Handle, Handle, Handle, ProcessHandle)
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 ]
        Maybe String
forall a. Maybe a
Nothing
        Maybe [(String, String)]
forall a. Maybe a
Nothing

    release :: (Handle, Handle, Handle, Process.ProcessHandle) -> m ()
    release :: (Handle, Handle, Handle, ProcessHandle) -> m ()
release (Handle
stdin, Handle
stdout, Handle
stderr, ProcessHandle
handle) =
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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)

  m (Handle, Handle, Handle, ProcessHandle)
-> ((Handle, Handle, Handle, ProcessHandle) -> m ())
-> ((Handle, Handle, Handle, ProcessHandle) -> m a)
-> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (Handle, Handle, Handle, ProcessHandle)
acquire (Handle, Handle, Handle, ProcessHandle) -> m ()
release (((Handle, Handle, Handle, ProcessHandle) -> m a) -> m a)
-> ((Handle, Handle, Handle, ProcessHandle) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \(Handle
stdin, Handle
stdout, Handle
stderr, ProcessHandle
_handle) -> do
    -- No need to keep it around...
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
stdin
    Handle -> Handle -> m 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 -> forall (m :: * -> *). MonadDocker m => m Image
runToImage              :: forall m. MonadDocker m => m Image
  , ToImage -> ContainerRequest -> ContainerRequest
applyToContainerRequest :: ContainerRequest -> ContainerRequest
  }


-- | Build the `Image` referred to by the argument. If the construction of the
-- image is expensive (e.g. a call to `fromBuildContext`) we don't want to
-- repeatedly build the image. Instead, `build` can be used to execute the
-- underlying Docker build once and re-use the resulting `Image`.
--
-- @since 0.1.0.0
--
build :: MonadDocker m => ToImage -> m ToImage
build :: ToImage -> m ToImage
build toImage :: ToImage
toImage@ToImage { ContainerRequest -> ContainerRequest
applyToContainerRequest :: ContainerRequest -> ContainerRequest
$sel:applyToContainerRequest:ToImage :: ToImage -> ContainerRequest -> ContainerRequest
applyToContainerRequest } = do
  Image
image <- ToImage -> forall (m :: * -> *). MonadDocker m => m Image
runToImage ToImage
toImage
  ToImage -> m ToImage
forall (m :: * -> *) a. Monad m => a -> m a
return (ToImage -> m ToImage) -> ToImage -> m ToImage
forall a b. (a -> b) -> a -> b
$ ToImage :: (forall (m :: * -> *). MonadDocker m => m Image)
-> (ContainerRequest -> ContainerRequest) -> ToImage
ToImage
    {
      $sel:runToImage:ToImage :: forall (m :: * -> *). MonadDocker m => m Image
runToImage = Image -> m Image
forall (f :: * -> *) a. Applicative f => a -> f a
pure Image
image
    , ContainerRequest -> ContainerRequest
applyToContainerRequest :: ContainerRequest -> ContainerRequest
$sel:applyToContainerRequest:ToImage :: ContainerRequest -> ContainerRequest
applyToContainerRequest
    }


-- | Default `ToImage`. Doesn't apply anything to to `ContainerRequests`.
--
-- @since 0.1.0.0
--
defaultToImage :: (forall m . MonadDocker m => m Image) -> ToImage
defaultToImage :: (forall (m :: * -> *). MonadDocker m => m Image) -> ToImage
defaultToImage forall (m :: * -> *). MonadDocker m => m Image
action = ToImage :: (forall (m :: * -> *). MonadDocker m => m Image)
-> (ContainerRequest -> ContainerRequest) -> ToImage
ToImage
  {
    $sel:runToImage:ToImage :: forall (m :: * -> *). MonadDocker m => m Image
runToImage = forall (m :: * -> *). MonadDocker m => m Image
action
  , $sel:applyToContainerRequest:ToImage :: ContainerRequest -> ContainerRequest
applyToContainerRequest = \ContainerRequest
x -> ContainerRequest
x
  }


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


-- | Identifies a container within the Docker runtime. Assigned by @docker run@.
--
-- @since 0.1.0.0
--
type ContainerId = Text


-- | A strategy that describes how to asses readiness of a `Container`. Allows
-- Users to plug in their definition of readiness.
--
-- @since 0.1.0.0
--
newtype WaitUntilReady = WaitUntilReady
  {
    WaitUntilReady -> Config -> Container -> (Maybe Int, ResIO ())
checkContainerReady :: Config -> Container -> (Maybe Int, ResIO ())
  }


-- | The exception thrown by `waitForLine` in case the expected log line
-- wasn't found.
--
-- @since 0.1.0.0
--
newtype UnexpectedEndOfPipe = UnexpectedEndOfPipe
  {
    -- | The id of the underlying container.
    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
/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
$c/= :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
$c== :: UnexpectedEndOfPipe -> UnexpectedEndOfPipe -> Bool
Eq, Int -> UnexpectedEndOfPipe -> ShowS
[UnexpectedEndOfPipe] -> ShowS
UnexpectedEndOfPipe -> String
(Int -> UnexpectedEndOfPipe -> ShowS)
-> (UnexpectedEndOfPipe -> String)
-> ([UnexpectedEndOfPipe] -> ShowS)
-> Show UnexpectedEndOfPipe
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
(TimeoutException -> TimeoutException -> Bool)
-> (TimeoutException -> TimeoutException -> Bool)
-> Eq TimeoutException
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
(Int -> TimeoutException -> ShowS)
-> (TimeoutException -> String)
-> ([TimeoutException] -> ShowS)
-> Show TimeoutException
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


-- | @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
seconds WaitUntilReady
wait = (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
WaitUntilReady ((Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady)
-> (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Config
config Container
container ->
  case WaitUntilReady -> Config -> Container -> (Maybe Int, ResIO ())
checkContainerReady WaitUntilReady
wait Config
config Container
container of
    (Maybe Int
Nothing, ResIO ()
check) ->
      (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seconds, ResIO ()
check)
    (Just Int
innerTimeout, ResIO ()
check)
      | Int
innerTimeout Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
seconds ->
          (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seconds, ResIO ()
check)
      | Bool
otherwise ->
          (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
innerTimeout, ResIO ()
check)


-- | Waits until the port of a container is ready to accept connections.
-- This combinator should always be used with `waitUntilTimeout`.
--
-- @since 0.1.0.0
--
waitUntilMappedPortReachable
  :: Int
  -> WaitUntilReady
waitUntilMappedPortReachable :: Int -> WaitUntilReady
waitUntilMappedPortReachable Int
port = (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
WaitUntilReady ((Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady)
-> (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Config
config Container
container ->
  (HasCallStack => (Maybe Int, ResIO ())) -> (Maybe Int, ResIO ())
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => (Maybe Int, ResIO ())) -> (Maybe Int, ResIO ()))
-> (HasCallStack => (Maybe Int, ResIO ())) -> (Maybe Int, ResIO ())
forall a b. (a -> b) -> a -> b
$

  let
    Config { Tracer
configTracer :: Tracer
$sel:configTracer:Config :: Config -> Tracer
configTracer } = Config
config

    -- TODO add a parameterizable function when we will support host
    -- mapping exposure
    hostIp :: String
    hostIp :: String
hostIp = String
"0.0.0.0"

    hostPort :: Int
    hostPort :: Int
hostPort = Container -> Int -> Int
containerPort Container
container Int
port

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

    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 (f :: * -> *) a. Applicative f => a -> f a
pure Socket
socket

    retry :: IO ()
retry = do
      Either IOException Socket
result <- IO Socket -> IO (Either IOException Socket)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO AddrInfo
resolve IO AddrInfo -> (AddrInfo -> IO Socket) -> IO Socket
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 (String -> Text
pack String
hostIp) Int
hostPort Maybe IOException
forall a. Maybe a
Nothing)
          Socket -> IO ()
Socket.close Socket
socket
          () -> IO ()
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 (String -> Text
pack String
hostIp) Int
hostPort (IOException -> Maybe IOException
forall a. a -> Maybe a
Just IOException
exception))
          Int -> IO ()
threadDelay Int
500000
          IO ()
retry

  in
    (Maybe Int
forall a. Maybe a
Nothing, IO () -> ResIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
retry)


-- | A low-level primitive that allows scanning the logs for specific log lines
-- that indicate readiness of a container.
--
-- The `Handle`s passed to the function argument represent @stdout@ and @stderr@
-- of the container.
--
-- @since 0.1.0.0
--
waitWithLogs :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
waitWithLogs :: (Container -> Handle -> Handle -> IO ()) -> WaitUntilReady
waitWithLogs Container -> Handle -> Handle -> IO ()
waiter = (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
WaitUntilReady ((Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady)
-> (Config -> Container -> (Maybe Int, ResIO ())) -> WaitUntilReady
forall a b. (a -> b) -> a -> b
$ \Config
config Container
container ->
  let
    check :: ResIO ()
check = (ReaderT Config (ResourceT IO) () -> Config -> ResIO ())
-> Config -> ReaderT Config (ResourceT IO) () -> ResIO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Config (ResourceT IO) () -> Config -> ResIO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Config
config (ReaderT Config (ResourceT IO) () -> ResIO ())
-> ReaderT Config (ResourceT IO) () -> ResIO ()
forall a b. (a -> b) -> a -> b
$ Container
-> (Handle -> Handle -> ReaderT Config (ResourceT IO) ())
-> ReaderT Config (ResourceT IO) ()
forall (m :: * -> *) a.
MonadDocker m =>
Container -> (Handle -> Handle -> m a) -> m a
withLogs Container
container ((Handle -> Handle -> ReaderT Config (ResourceT IO) ())
 -> ReaderT Config (ResourceT IO) ())
-> (Handle -> Handle -> ReaderT Config (ResourceT IO) ())
-> ReaderT Config (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ \Handle
stdout Handle
stderr ->
      IO () -> ReaderT Config (ResourceT IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Config (ResourceT IO) ())
-> IO () -> ReaderT Config (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ Container -> Handle -> Handle -> IO ()
waiter Container
container Handle
stdout Handle
stderr
  in
    (Maybe Int
forall a. Maybe a
Nothing, ResIO ()
check)


-- | A data type indicating which pipe to scan for a specific log line.
--
-- @since 0.1.0.0
--
data Pipe
  -- | Refer to logs on STDOUT.
  = Stdout
  -- | Refer to logs on STDERR.
  | Stderr
  deriving (Pipe -> Pipe -> Bool
(Pipe -> Pipe -> Bool) -> (Pipe -> Pipe -> Bool) -> Eq Pipe
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pipe -> Pipe -> Bool
$c/= :: Pipe -> Pipe -> Bool
== :: Pipe -> Pipe -> Bool
$c== :: Pipe -> Pipe -> Bool
Eq, Eq Pipe
Eq Pipe
-> (Pipe -> Pipe -> Ordering)
-> (Pipe -> Pipe -> Bool)
-> (Pipe -> Pipe -> Bool)
-> (Pipe -> Pipe -> Bool)
-> (Pipe -> Pipe -> Bool)
-> (Pipe -> Pipe -> Pipe)
-> (Pipe -> Pipe -> Pipe)
-> Ord Pipe
Pipe -> Pipe -> Bool
Pipe -> Pipe -> Ordering
Pipe -> Pipe -> Pipe
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 :: Pipe -> Pipe -> Pipe
$cmin :: Pipe -> Pipe -> Pipe
max :: Pipe -> Pipe -> Pipe
$cmax :: Pipe -> Pipe -> Pipe
>= :: Pipe -> Pipe -> Bool
$c>= :: Pipe -> Pipe -> Bool
> :: Pipe -> Pipe -> Bool
$c> :: Pipe -> Pipe -> Bool
<= :: Pipe -> Pipe -> Bool
$c<= :: Pipe -> Pipe -> Bool
< :: Pipe -> Pipe -> Bool
$c< :: Pipe -> Pipe -> Bool
compare :: Pipe -> Pipe -> Ordering
$ccompare :: Pipe -> Pipe -> Ordering
$cp1Ord :: Eq Pipe
Ord, Int -> Pipe -> ShowS
[Pipe] -> ShowS
Pipe -> String
(Int -> Pipe -> ShowS)
-> (Pipe -> String) -> ([Pipe] -> ShowS) -> Show Pipe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pipe] -> ShowS
$cshowList :: [Pipe] -> ShowS
show :: Pipe -> String
$cshow :: Pipe -> String
showsPrec :: Int -> Pipe -> ShowS
$cshowsPrec :: Int -> Pipe -> ShowS
Show)


-- | Waits for a specific line to occur in the logs. Throws a `UnexpectedEndOfPipe`
-- exception in case the desired line can not be found on the logs.
--
-- Say you want to find "Ready to accept connections" in the logs on Stdout try:
--
-- @
-- wairForLogLine 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
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!
      (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Text
Nothing -> UnexpectedEndOfPipe -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (UnexpectedEndOfPipe -> IO ()) -> UnexpectedEndOfPipe -> IO ()
forall a b. (a -> b) -> a -> b
$ UnexpectedEndOfPipe :: Text -> UnexpectedEndOfPipe
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.
--
-- @since 0.1.0.0
--
waitUntilReady :: MonadDocker m => Container -> WaitUntilReady -> m ()
waitUntilReady :: Container -> WaitUntilReady -> m ()
waitUntilReady container :: Container
container@Container { Text
id :: Text
$sel:id:Container :: Container -> Text
id } WaitUntilReady
waiter = do
  config :: Config
config@Config { Maybe Int
configDefaultWaitTimeout :: Maybe Int
$sel:configDefaultWaitTimeout:Config :: Config -> Maybe Int
configDefaultWaitTimeout, Tracer
configTracer :: Tracer
$sel:configTracer:Config :: Config -> Tracer
configTracer } <- m Config
forall r (m :: * -> *). MonadReader r m => m r
ask
  let
    (Maybe Int
timeoutInSeconds, ResIO ()
check) =
      WaitUntilReady -> Config -> Container -> (Maybe Int, ResIO ())
checkContainerReady WaitUntilReady
waiter Config
config Container
container

    runAction :: m b -> Maybe Int -> m b
runAction m b
action Maybe Int
timeoutSeconds = do
      Tracer -> Trace -> m ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
configTracer (Maybe Int -> Trace
TraceWaitUntilReady Maybe Int
timeoutSeconds)
      m b
action

    withTimeout :: m () -> m ()
withTimeout m ()
action = case Maybe Int
timeoutInSeconds Maybe Int -> Maybe Int -> Maybe Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Int
configDefaultWaitTimeout of
      Maybe Int
Nothing ->
        m () -> Maybe Int -> m ()
forall (m :: * -> *) b. MonadIO m => m b -> Maybe Int -> m b
runAction m ()
action Maybe Int
forall a. Maybe a
Nothing
      Just Int
seconds ->
        ((forall a. m a -> IO a) -> IO ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO ()) -> m ())
-> ((forall a. m a -> IO a) -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m 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
$ m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> Maybe Int -> m ()
forall (m :: * -> *) b. MonadIO m => m b -> Maybe Int -> m b
runAction m ()
action (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seconds))
          case Maybe ()
result of
            Maybe ()
Nothing ->
              TimeoutException -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TimeoutException -> IO ()) -> TimeoutException -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeoutException :: Text -> TimeoutException
TimeoutException { Text
id :: Text
$sel:id:TimeoutException :: Text
id }
            Just ()
_ ->
              () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  ResIO () -> m ()
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ResIO () -> ResIO ()
forall (m :: * -> *). MonadUnliftIO m => m () -> m ()
withTimeout ResIO ()
check)


-- | Handle to a Docker image.
--
-- @since 0.1.0.0
--
data Image = Image
  {
    -- | The image tag assigned by Docker. Uniquely identifies an `Image`
    -- within Docker.
    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
/= :: Image -> Image -> Bool
$c/= :: Image -> Image -> Bool
== :: Image -> Image -> Bool
$c== :: Image -> Image -> Bool
Eq, Int -> Image -> ShowS
[Image] -> ShowS
Image -> String
(Int -> Image -> ShowS)
-> (Image -> String) -> ([Image] -> ShowS) -> Show Image
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
  }


-- | The parsed JSON output of docker inspect command.
--
-- @since 0.1.0.0
--
type InspectOutput = Value


-- | Returns the id of the container.
--
-- @since 0.1.0.0
--
containerId :: Container -> ContainerId
containerId :: Container -> 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


-- | 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
    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
^? Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
"NetworkSettings"
    AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
"IPAddress"
    AffineTraversal' InspectOutput InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' An_AffineTraversal '[] InspectOutput Text
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
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. AsPrimitive 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 -> DockerException
InspectOutputUnexpected { Text
id :: Text
$sel:id:DockerException :: Text
id }

    Just Text
address ->
      Text
address


-- | Looks up an exposed port on the host.
--
-- @since 0.1.0.0
--
containerPort :: Container -> Int -> Int
containerPort :: Container -> Int -> Int
containerPort Container { Text
id :: Text
$sel:id:Container :: Container -> Text
id, InspectOutput
inspectOutput :: InspectOutput
$sel:inspectOutput:Container :: Container -> InspectOutput
inspectOutput } Int
port =
  let
    -- TODO also support UDP ports
    textPort :: Text
    textPort :: Text
textPort = String -> Text
pack (Int -> String
forall a. Show a => a -> String
show Int
port) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/tcp"
  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 (Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
"NetworkSettings"
           AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
"Ports"
           AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
-> AffineTraversal' InspectOutput InspectOutput
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
textPort
           AffineTraversal' InspectOutput InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
-> Optic
     A_Traversal
     '[Int]
     InspectOutput
     InspectOutput
     InspectOutput
     InspectOutput
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
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 m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Text -> AffineTraversal' InspectOutput InspectOutput
forall t. AsValue t => Text -> AffineTraversal' t InspectOutput
Optics.key Text
"HostPort"
           Optic
  A_Traversal
  '[Int]
  InspectOutput
  InspectOutput
  InspectOutput
  InspectOutput
-> Optic A_Prism '[] InspectOutput InspectOutput Text Text
-> Optic' A_Traversal '[Int] InspectOutput Text
forall k m l (ks :: IxList) (is :: IxList) (js :: IxList) s t u v a
       b.
(Is k m, Is l m, m ~ Join k l, ks ~ Append is js) =>
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. AsPrimitive 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 -> Text -> DockerException
UnknownPortMapping
          {
            Text
id :: Text
$sel:id:DockerException :: Text
id
          , $sel:port:DockerException :: Text
port = Text
textPort
          }
      Just Text
hostPort ->
        String -> Int
forall a. Read a => String -> a
read (Text -> String
unpack Text
hostPort)


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


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


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


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