{-# 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,
  )
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)

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

-- | 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 =
  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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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"
      (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
args)
      (Text -> String
unpack Text
stdin)

  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
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Trace
TraceDockerStdout forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> [String]
lines String
stdout)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *). MonadIO m => Tracer -> Trace -> m ()
withTrace Tracer
tracer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Trace
TraceDockerStderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> [String]
lines String
stderr)

  case ExitCode
exitCode of
    ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stdout
    ExitCode
_ ->
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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
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
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
Ord, Int -> Pipe -> ShowS
[Pipe] -> ShowS
Pipe -> String
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)

-- | 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) <-
    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 forall a b. (a -> b) -> a -> b
$
              (String -> [String] -> CreateProcess
Process.proc String
"docker" (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
dockerArgs))
                { std_out :: StdStream
Process.std_out = StdStream
Process.CreatePipe,
                  std_err :: StdStream
Process.std_err = StdStream
Process.CreatePipe
                }

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

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

          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
          forall a. Async a -> IO ()
Async.cancel Async Any
stdoutReporter
          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
      )

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