{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module TestContainers.Docker.Internal
  ( DockerException (..),

    -- * Container related stuff
    ContainerId,
    InspectOutput,

    -- * Network related stuff
    NetworkId,

    -- * Running docker
    docker,
    dockerWithStdin,

    -- * Following logs
    Pipe (..),
    LogConsumer,
    consoleLogConsumer,
    dockerFollowLogs,

    -- * Common abstractions for Docker resources
    WithoutReaper (..),
  )
where

import qualified Control.Concurrent.Async as Async
import Control.Exception (Exception)
import Control.Monad (forever)
import Control.Monad.Catch (throwM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, allocate)
import Data.Aeson (Value)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.Foldable (traverse_)
import Data.Text (Text, pack, unpack)
import System.Exit (ExitCode (..))
import qualified System.IO
import qualified System.Process as Process
import TestContainers.Trace (Trace (..), Tracer, withTrace)

-- | Shared property between Docker resources.
class WithoutReaper request where
  -- | Do not register the docker resource (container, register, etc.) with the resource reaper.
  -- Careful, doing this will make your container leak on shutdown if not explicitly stopped.
  --
  -- @since 0.5.1.0
  withoutReaper :: request -> request

-- | Identifies a network within the Docker runtime. Assigned by @docker network create@
--
-- @since 0.5.0.0
type NetworkId = Text

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

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

-- | Failing to interact with Docker results in this exception
-- being thrown.
--
-- @since 0.1.0.0
data DockerException
  = DockerException
      { -- | Exit code of the underlying Docker process.
        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}
  | InspectOutputMissingNetwork {id :: ContainerId}
  | InspectOutputUnexpected {id :: ContainerId}
  | UnknownPortMapping
      { -- | Id of the `Container` that we tried to lookup the
        -- port mapping.
        id :: ContainerId,
        -- | Textual representation of port mapping we were
        -- trying to look up.
        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
$c== :: DockerException -> DockerException -> Bool
== :: DockerException -> DockerException -> Bool
$c/= :: DockerException -> DockerException -> Bool
/= :: 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
$cshowsPrec :: Int -> DockerException -> ShowS
showsPrec :: Int -> DockerException -> ShowS
$cshow :: DockerException -> String
show :: DockerException -> String
$cshowList :: [DockerException] -> ShowS
showList :: [DockerException] -> ShowS
Show)

instance Exception DockerException

-- | Internal function that runs Docker. Takes care of throwing an exception
-- in case of failure.
--
-- @since 0.1.0.0
docker :: (MonadIO m) => Tracer -> [Text] -> m String
docker :: forall (m :: * -> *). MonadIO m => 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 :: forall (m :: * -> *).
MonadIO m =>
Tracer -> [Text] -> Text -> m String
dockerWithStdin Tracer
tracer [Text]
args Text
stdin = IO String -> m String
forall a. IO a -> m a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stdout
    ExitCode
_ ->
      DockerException -> IO String
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (DockerException -> IO String) -> DockerException -> IO String
forall a b. (a -> b) -> a -> b
$
        DockerException
          { ExitCode
exitCode :: ExitCode
exitCode :: ExitCode
exitCode,
            [Text]
args :: [Text]
args :: [Text]
args,
            stderr :: Text
stderr = String -> Text
pack String
stderr
          }

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

-- | An abstraction for forwarding logs.
--
-- @since 0.5.0.0
type LogConsumer = Pipe -> ByteString -> IO ()

-- | A simple 'LogConsumer' that writes log lines to stdout and stderr respectively.
--
-- @since 0.5.0.0
consoleLogConsumer :: LogConsumer
consoleLogConsumer :: LogConsumer
consoleLogConsumer Pipe
pipe ByteString
line = do
  case Pipe
pipe of
    Pipe
Stdout -> do
      Handle -> ByteString -> IO ()
ByteString.hPutStr Handle
System.IO.stdout ByteString
line
      Handle -> ByteString -> IO ()
ByteString.hPut Handle
System.IO.stdout (Word8 -> ByteString
ByteString.singleton Word8
0x0a)
    Pipe
Stderr -> do
      Handle -> ByteString -> IO ()
ByteString.hPutStr Handle
System.IO.stderr ByteString
line
      Handle -> ByteString -> IO ()
ByteString.hPut Handle
System.IO.stderr (Word8 -> ByteString
ByteString.singleton Word8
0x0a)

-- | Forwards container logs to a 'LogConsumer'. This is equivalent of calling @docker logs containerId --follow@
--
-- @since 0.5.0.0
dockerFollowLogs :: (MonadResource m) => Tracer -> ContainerId -> LogConsumer -> m ()
dockerFollowLogs :: forall (m :: * -> *).
MonadResource m =>
Tracer -> Text -> LogConsumer -> m ()
dockerFollowLogs Tracer
tracer Text
containerId LogConsumer
logConsumer = do
  let dockerArgs :: [Text]
dockerArgs =
        [Text
"logs", Text
containerId, Text
"--follow"]

  (ReleaseKey
_releaseKey, ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
 Async Any, Async Any)
_result) <-
    IO
  ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
   Async Any, Async Any)
-> (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
     Async Any, Async Any)
    -> IO ())
-> m (ReleaseKey,
      ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
       Async Any, Async Any))
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
      ( do
          process :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
process@(Maybe Handle
_stdin, Just Handle
stdout, Just Handle
stderr, ProcessHandle
_processHandle) <-
            CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Process.createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
              (String -> [String] -> CreateProcess
Process.proc String
"docker" ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
dockerArgs))
                { Process.std_out = Process.CreatePipe,
                  Process.std_err = Process.CreatePipe
                }

          Tracer -> Trace -> IO ()
forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer ([Text] -> Trace
TraceDockerFollowLogs [Text]
dockerArgs)

          Async Any
stdoutReporter <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
Async.async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ do
            IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
              ByteString
line <- Handle -> IO ByteString
ByteString.hGetLine Handle
stdout
              LogConsumer
logConsumer Pipe
Stdout ByteString
line

          Async Any
stderrReporter <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
Async.async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ do
            IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
              ByteString
line <- Handle -> IO ByteString
ByteString.hGetLine Handle
stderr
              LogConsumer
logConsumer Pipe
Stderr ByteString
line

          ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
 Async Any, Async Any)
-> IO
     ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle),
      Async Any, Async Any)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
process, Async Any
stdoutReporter, Async Any
stderrReporter)
      )
      ( \((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
process, Async Any
stdoutReporter, Async Any
stderrReporter) -> do
          Async Any -> IO ()
forall a. Async a -> IO ()
Async.cancel Async Any
stdoutReporter
          Async Any -> IO ()
forall a. Async a -> IO ()
Async.cancel Async Any
stderrReporter
          (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
Process.cleanupProcess (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
process
      )

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