Internal.hs

{-# 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.4.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.
        exitCode :: ExitCode,
        -- | Arguments that were passed to Docker.
        args :: [Text],
        -- | Docker's STDERR output.
        stderr :: Text
      }
  | InspectUnknownContainerId {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.
        port :: Text
      }
  deriving (Eq, 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 tracer args =
  dockerWithStdin tracer args ""

-- | 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 args stdin = liftIO $ do
  (exitCode, stdout, stderr) <-
    Process.readProcessWithExitCode
      "docker"
      (map unpack args)
      (unpack stdin)

  withTrace tracer (TraceDockerInvocation args stdin exitCode)

  -- TODO output these concurrently with the process
  traverse_ (withTrace tracer . TraceDockerStdout . pack) (lines stdout)
  traverse_ (withTrace tracer . TraceDockerStderr . pack) (lines stderr)

  case exitCode of
    ExitSuccess -> pure stdout
    _ ->
      throwM $
        DockerException
          { exitCode,
            args,
            stderr = pack 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 (Eq, Ord, Show)

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

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

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

  (_releaseKey, _result) <-
    allocate
      ( do
          process@(_stdin, Just stdout, Just stderr, _processHandle) <-
            Process.createProcess $
              (Process.proc "docker" (map unpack dockerArgs))
                { Process.std_out = Process.CreatePipe,
                  Process.std_err = Process.CreatePipe
                }

          withTrace tracer (TraceDockerFollowLogs dockerArgs)

          stdoutReporter <- Async.async $ do
            forever $ do
              line <- ByteString.hGetLine stdout
              logConsumer Stdout line

          stderrReporter <- Async.async $ do
            forever $ do
              line <- ByteString.hGetLine stderr
              logConsumer Stderr line

          pure (process, stdoutReporter, stderrReporter)
      )
      ( \(process, stdoutReporter, stderrReporter) -> do
          Async.cancel stdoutReporter
          Async.cancel stderrReporter
          Process.cleanupProcess process
      )

  pure ()