{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE NoFieldSelectors    #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | Run commands in Docker containers
module Stack.Docker
  ( dockerCmdName
  , dockerHelpOptName
  , dockerPullCmdName
  , entrypoint
  , preventInContainer
  , pull
  , reset
  , reExecArgName
  , DockerException (..)
  , getProjectRoot
  , runContainerAndExit
  ) where

import qualified Crypto.Hash as Hash ( Digest, MD5, hash )
import           Data.Aeson ( eitherDecode )
import           Data.Aeson.Types ( FromJSON (..), (.!=) )
import           Data.Aeson.WarningParser ( (.:), (.:?) )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as LBS
import           Data.Char ( isAscii, isDigit )
import           Data.Conduit.List ( sinkNull )
import           Data.List ( dropWhileEnd, isInfixOf, isPrefixOf )
import           Data.List.Extra ( trim )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Time ( UTCTime )
import qualified Data.Version ( parseVersion )
import           Distribution.Version ( mkVersion, mkVersion' )
import           Path
                   ( (</>), dirname, filename, parent, parseAbsDir
                   , splitExtension
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( copyFile, doesDirExist, doesFileExist, ensureDir
                   , getCurrentDir, getHomeDir, getModificationTime, listDir
                   , removeDirRecur, removeFile, resolveFile'
                   )
import qualified RIO.Directory ( makeAbsolute )
import           RIO.Process
                   ( ExitCodeException (..), HasProcessContext, augmentPath
                   , closed, doesExecutableExist, proc, processContextL
                   , readProcessStdout_, readProcess_, runProcess, runProcess_
                   , setStderr, setStdin, setStdout, useHandleOpen
                   , withWorkingDir
                   )
import           Stack.Config ( getInContainer )
import           Stack.Constants
                   ( buildPlanDir, inContainerEnvVar, platformVariantEnvVar
                   , relDirBin, relDirDotLocal, relDirDotSsh
                   , relDirDotStackProgName, relDirUnderHome, stackRootEnvVar
                   )
import           Stack.Constants.Config ( projectDockerSandboxDir )
import           Stack.Docker.Handlers ( handleSetGroups, handleSignals )
import           Stack.Prelude
import           Stack.Setup ( ensureDockerStackExe )
import           Stack.Storage.User
                   ( loadDockerImageExeCache, saveDockerImageExeCache )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), configProjectRoot, stackRootL
                   )
import           Stack.Types.Docker
                  ( DockerException (..), DockerOpts (..), DockerStackExe (..)
                  , Mount (..), dockerCmdName, dockerContainerPlatform
                  , dockerEntrypointArgName, dockerHelpOptName
                  , dockerPullCmdName, reExecArgName
                  )
import           Stack.Types.DockerEntrypoint
                   ( DockerEntrypoint (..), DockerUser (..) )
import           Stack.Types.Runner ( HasDockerEntrypointMVar (..), terminalL )
import           Stack.Types.Version ( showStackVersion, withinRange )
import           System.Environment
                   ( getArgs, getEnv, getEnvironment, getExecutablePath
                   , getProgName
                   )
import qualified System.FilePath as FP
import           System.IO.Error ( isDoesNotExistError )
import qualified System.Posix.User as User
import qualified System.PosixCompat.Files as Files
import           System.Terminal ( hIsTerminalDeviceOrMinTTY )
import           Text.ParserCombinators.ReadP ( readP_to_S )

-- | Function to get command and arguments to run in Docker container
getCmdArgs ::
     HasConfig env
  => DockerOpts
  -> Inspect
  -> Bool
  -> RIO env (FilePath,[String],[(String,String)],[Mount])
getCmdArgs docker imageInfo isRemoteDocker = do
    config <- view configL
    user <-
        if fromMaybe (not isRemoteDocker) docker.setUser
            then liftIO $ do
              uid <- User.getEffectiveUserID
              gid <- User.getEffectiveGroupID
              groups <- nubOrd <$> User.getGroups
              umask <- Files.setFileCreationMask 0o022
              -- Only way to get old umask seems to be to change it, so set it back afterward
              _ <- Files.setFileCreationMask umask
              pure $ Just DockerUser
                { uid
                , gid
                , groups
                , umask
                }
            else pure Nothing
    args <-
        fmap
          (  [ "--" ++ reExecArgName ++ "=" ++ showStackVersion
             , "--" ++ dockerEntrypointArgName
             , show DockerEntrypoint { user }
             ] ++
          )
          (liftIO getArgs)
    case config.docker.stackExe of
        Just DockerStackExeHost
          | config.platform == dockerContainerPlatform -> do
              exePath <- resolveFile' =<< liftIO getExecutablePath
              cmdArgs args exePath
          | otherwise -> throwIO UnsupportedStackExeHostPlatformException
        Just DockerStackExeImage -> do
            progName <- liftIO getProgName
            pure (FP.takeBaseName progName, args, [], [])
        Just (DockerStackExePath path) -> cmdArgs args path
        Just DockerStackExeDownload -> exeDownload args
        Nothing
          | config.platform == dockerContainerPlatform -> do
              (exePath, exeTimestamp, misCompatible) <-
                  do exePath <- resolveFile' =<< liftIO getExecutablePath
                     exeTimestamp <- getModificationTime exePath
                     isKnown <-
                         loadDockerImageExeCache
                             imageInfo.iiId
                             exePath
                             exeTimestamp
                     pure (exePath, exeTimestamp, isKnown)
              case misCompatible of
                  Just True -> cmdArgs args exePath
                  Just False -> exeDownload args
                  Nothing -> do
                      e <-
                          try $
                          sinkProcessStderrStdout
                              "docker"
                              [ "run"
                              , "-v"
                              , toFilePath exePath ++ ":" ++ "/tmp/stack"
                              , T.unpack imageInfo.iiId
                              , "/tmp/stack"
                              , "--version"]
                              sinkNull
                              sinkNull
                      let compatible =
                              case e of
                                  Left ExitCodeException{} -> False
                                  Right _ -> True
                      saveDockerImageExeCache
                          imageInfo.iiId
                          exePath
                          exeTimestamp
                          compatible
                      if compatible
                          then cmdArgs args exePath
                          else exeDownload args
        Nothing -> exeDownload args
  where
    exeDownload args = do
        exePath <- ensureDockerStackExe dockerContainerPlatform
        cmdArgs args exePath
    cmdArgs args exePath = do
        -- MSS 2020-04-21 previously used replaceExtension, but semantics changed in path 0.7
        -- In any event, I'm not even sure _why_ we need to drop a file extension here
        -- Originally introduced here: https://github.com/commercialhaskell/stack/commit/6218dadaf5fd7bf312bb1bd0db63b4784ba78cb2
        let exeBase =
              case splitExtension exePath of
                Left _ -> exePath
                Right (x, _) -> x
        let mountPath = hostBinDir FP.</> toFilePath (filename exeBase)
        pure (mountPath, args, [], [Mount (toFilePath exePath) mountPath])

-- | Error if running in a container.
preventInContainer :: MonadIO m => m () -> m ()
preventInContainer inner =
  do inContainer <- getInContainer
     if inContainer
        then throwIO OnlyOnHostException
        else inner

-- | Run a command in a new Docker container, then exit the process.
runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit = do
  config <- view configL
  let docker = config.docker
  checkDockerVersion docker
  (env, isStdinTerminal, isStderrTerminal, homeDir) <- liftIO $
    (,,,)
    <$> getEnvironment
    <*> hIsTerminalDeviceOrMinTTY stdin
    <*> hIsTerminalDeviceOrMinTTY stderr
    <*> getHomeDir
  isStdoutTerminal <- view terminalL
  let dockerHost = lookup "DOCKER_HOST" env
      dockerCertPath = lookup "DOCKER_CERT_PATH" env
      bamboo = lookup "bamboo_buildKey" env
      jenkins = lookup "JENKINS_HOME" env
      msshAuthSock = lookup "SSH_AUTH_SOCK" env
      muserEnv = lookup "USER" env
      isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost
  mstackYaml <- for (lookup "STACK_YAML" env) RIO.Directory.makeAbsolute
  image <- either throwIO pure docker.image
  when
    ( isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath )
    ( prettyWarnS
        "Using boot2docker is NOT supported, and not likely to perform well."
    )
  maybeImageInfo <- inspect image
  imageInfo <- case maybeImageInfo of
    Just ii -> pure ii
    Nothing
      | docker.autoPull -> do
          pullImage docker image
          mii2 <- inspect image
          case mii2 of
            Just ii2 -> pure ii2
            Nothing -> throwM (InspectFailedException image)
      | otherwise -> throwM (NotPulledException image)
  projectRoot <- getProjectRoot
  sandboxDir <- projectDockerSandboxDir projectRoot
  let ic = imageInfo.config
      imageEnvVars = map (break (== '=')) ic.env
      platformVariant = show $ hashRepoName image
      stackRoot = view stackRootL config
      sandboxHomeDir = sandboxDir </> homeDirName
      isTerm = not docker.detach &&
               isStdinTerminal &&
               isStdoutTerminal &&
               isStderrTerminal
      keepStdinOpen = not docker.detach &&
                      -- Workaround for https://github.com/docker/docker/issues/12319
                      -- This is fixed in Docker 1.9.1, but will leave the workaround
                      -- in place for now, for users who haven't upgraded yet.
                      (isTerm || (isNothing bamboo && isNothing jenkins))
  let mpath = T.pack <$> lookupImageEnv "PATH" imageEnvVars
  when (isNothing mpath) $ do
    prettyWarnL
      [ flow "The Docker image does not set the PATH environment variable. \
             \This will likely fail. For further information, see"
      , style Url "https://github.com/commercialhaskell/stack/issues/2742" <> "."
      ]
  newPathEnv <- either throwM pure $ augmentPath
    [ hostBinDir
    , toFilePath (sandboxHomeDir </> relDirDotLocal </> relDirBin)
    ]
    mpath
  (cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker
  pwd <- getCurrentDir
  liftIO $ mapM_ ensureDir [sandboxHomeDir, stackRoot]
  -- Since $HOME is now mounted in the same place in the container we can
  -- just symlink $HOME/.ssh to the right place for the stack docker user
  let sshDir = homeDir </> sshRelDir
  sshDirExists <- doesDirExist sshDir
  sshSandboxDirExists <-
    liftIO
      (Files.fileExist
        (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)))
  when (sshDirExists && not sshSandboxDirExists)
    (liftIO
      (Files.createSymbolicLink
        (toFilePathNoTrailingSep sshDir)
        (toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))
  let mountSuffix = maybe "" (":" ++) docker.mountMode
  containerID <- withWorkingDir (toFilePath projectRoot) $
    trim . decodeUtf8 <$> readDockerProcess
      ( concat
        [ [ "create"
          , "-e", inContainerEnvVar ++ "=1"
          , "-e", stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
          , "-e", platformVariantEnvVar ++ "=dk" ++ platformVariant
          , "-e", "HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
          , "-e", "PATH=" ++ T.unpack newPathEnv
          , "-e", "PWD=" ++ toFilePathNoTrailingSep pwd
          , "-v"
          , toFilePathNoTrailingSep homeDir ++ ":" ++
              toFilePathNoTrailingSep homeDir ++ mountSuffix
          , "-v"
          , toFilePathNoTrailingSep stackRoot ++ ":" ++
              toFilePathNoTrailingSep stackRoot ++ mountSuffix
          , "-v"
          , toFilePathNoTrailingSep projectRoot ++ ":" ++
              toFilePathNoTrailingSep projectRoot ++ mountSuffix
          , "-v"
          , toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++
              toFilePathNoTrailingSep sandboxHomeDir ++ mountSuffix
          , "-w", toFilePathNoTrailingSep pwd
          ]
        , case docker.network of
            Nothing -> ["--net=host"]
            Just name -> ["--net=" ++ name]
        , case muserEnv of
            Nothing -> []
            Just userEnv -> ["-e","USER=" ++ userEnv]
        , case msshAuthSock of
            Nothing -> []
            Just sshAuthSock ->
              [ "-e","SSH_AUTH_SOCK=" ++ sshAuthSock
              , "-v",sshAuthSock ++ ":" ++ sshAuthSock
              ]
        , case mstackYaml of
            Nothing -> []
            Just stackYaml ->
              [ "-e","STACK_YAML=" ++ stackYaml
              , "-v",stackYaml++ ":" ++ stackYaml ++ ":ro"
              ]
           -- Disable the deprecated entrypoint in FP Complete-generated images
        , [ "--entrypoint=/usr/bin/env"
          |  isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars)
          && (  ic.entrypoint == ["/usr/local/sbin/docker-entrypoint"]
             || ic.entrypoint == ["/root/entrypoint.sh"]
             )
          ]
        , concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
        , concatMap (mountArg mountSuffix) (extraMount ++ docker.mount)
        , concatMap (\nv -> ["-e", nv]) docker.env
        , case docker.containerName of
            Just name -> ["--name=" ++ name]
            Nothing -> []
        , ["-t" | isTerm]
        , ["-i" | keepStdinOpen]
        , docker.runArgs
        , [image]
        , [cmnd]
        , args
        ]
      )
  e <- handleSignals docker keepStdinOpen containerID
  case e of
    Left ExitCodeException{eceExitCode} -> exitWith eceExitCode
    Right () -> exitSuccess
  where
    -- This is using a hash of the Docker repository (without tag or digest) to
    -- ensure binaries/libraries aren't shared between Docker and host (or
    -- incompatible Docker images)
    hashRepoName :: String -> Hash.Digest Hash.MD5
    hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
    lookupImageEnv name vars =
      case lookup name vars of
        Just ('=':val) -> Just val
        _ -> Nothing
    mountArg mountSuffix (Mount host container) =
      ["-v",host ++ ":" ++ container ++ mountSuffix]
    sshRelDir = relDirDotSsh

-- | Inspect Docker image or container.
inspect :: (HasProcessContext env, HasLogFunc env)
        => String
        -> RIO env (Maybe Inspect)
inspect image = do
  results <- inspects [image]
  case Map.toList results of
    [] -> pure Nothing
    [(_,i)] -> pure (Just i)
    _ -> throwIO (InvalidInspectOutputException "expect a single result")

-- | Inspect multiple Docker images and/or containers.
inspects :: (HasProcessContext env, HasLogFunc env)
         => [String]
         -> RIO env (Map Text Inspect)
inspects [] = pure Map.empty
inspects images = do
  maybeInspectOut <-
    -- not using 'readDockerProcess' as the error from a missing image
    -- needs to be recovered.
    try (BL.toStrict . fst <$> proc "docker" ("inspect" : images) readProcess_)
  case maybeInspectOut of
    Right inspectOut ->
      -- filtering with 'isAscii' to workaround @docker inspect@ output
      -- containing invalid UTF-8
      case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of
        Left msg -> throwIO (InvalidInspectOutputException msg)
        Right results -> pure (Map.fromList (map (\r -> (r.iiId, r)) results))
    Left ece
      | any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes ->
          pure Map.empty
    Left e -> throwIO e
 where
  missingImagePrefixes = ["Error: No such image", "Error: No such object:"]

-- | Pull latest version of configured Docker image from registry.
pull :: HasConfig env => RIO env ()
pull = do
  config <- view configL
  let docker = config.docker
  checkDockerVersion docker
  either throwIO (pullImage docker) docker.image

-- | Pull Docker image from registry.
pullImage :: (HasProcessContext env, HasTerm env)
          => DockerOpts
          -> String
          -> RIO env ()
pullImage docker image = do
  prettyInfoL
    [ flow "Pulling image from registry:"
    , style Current (fromString image) <> "."
    ]
  when docker.registryLogin $ do
    prettyInfoS "You may need to log in."
    proc
      "docker"
      ( concat
          [ ["login"]
          , maybe [] (\n -> ["--username=" ++ n]) docker.registryUsername
          , maybe [] (\p -> ["--password=" ++ p]) docker.registryPassword
          , [takeWhile (/= '/') image]
          ]
      )
      runProcess_
  -- We redirect the stdout of the process to stderr so that the output
  -- of @docker pull@ will not interfere with the output of other
  -- commands when using --auto-docker-pull. See issue #2733.
  ec <- proc "docker" ["pull", image] $ \pc0 -> do
    let pc = setStdout (useHandleOpen stderr)
           $ setStderr (useHandleOpen stderr)
           $ setStdin closed
             pc0
    runProcess pc
  case ec of
    ExitSuccess -> pure ()
    ExitFailure _ -> throwIO (PullFailedException image)

-- | Check docker version (throws exception if incorrect)
checkDockerVersion ::
     (HasProcessContext env, HasLogFunc env)
  => DockerOpts
  -> RIO env ()
checkDockerVersion docker = do
  dockerExists <- doesExecutableExist "docker"
  unless dockerExists (throwIO DockerNotInstalledException)
  dockerVersionOut <- readDockerProcess ["--version"]
  case words (decodeUtf8 dockerVersionOut) of
    (_:_:v:_) ->
      case fmap mkVersion' $ parseVersion' $ stripVersion v of
        Just v'
          | v' < minimumDockerVersion ->
            throwIO (DockerTooOldException minimumDockerVersion v')
          | v' `elem` prohibitedDockerVersions ->
            throwIO (DockerVersionProhibitedException prohibitedDockerVersions v')
          | not (v' `withinRange` docker.requireDockerVersion) ->
            throwIO (BadDockerVersionException docker.requireDockerVersion v')
          | otherwise ->
            pure ()
        _ -> throwIO InvalidVersionOutputException
    _ -> throwIO InvalidVersionOutputException
 where
  minimumDockerVersion = mkVersion [1, 6, 0]
  prohibitedDockerVersions = []
  stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v)
  -- version is parsed by Data.Version provided code to avoid
  -- Cabal's Distribution.Version lack of support for leading zeros in version
  parseVersion' =
    fmap fst . listToMaybe . reverse . readP_to_S Data.Version.parseVersion

-- | Remove the project's Docker sandbox.
reset :: HasConfig env => Bool -> RIO env ()
reset keepHome = do
  projectRoot <- getProjectRoot
  dockerSandboxDir <- projectDockerSandboxDir projectRoot
  liftIO (removeDirectoryContents
            dockerSandboxDir
            [homeDirName | keepHome]
            [])

-- | The Docker container "entrypoint": special actions performed when first
-- entering a container, such as switching the UID/GID to the "outside-Docker"
-- user's.
entrypoint ::
     (HasDockerEntrypointMVar env, HasProcessContext env, HasLogFunc env)
  => Config
  -> DockerEntrypoint
  -> RIO env ()
entrypoint config@Config{} de = do
  entrypointMVar <- view dockerEntrypointMVarL
  modifyMVar_ entrypointMVar $ \alreadyRan -> do
    -- Only run the entrypoint once
    unless alreadyRan $ do
      envOverride <- view processContextL
      homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME"
      -- Get the UserEntry for the 'stack' user in the image, if it exists
      estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $
        User.getUserEntryForName stackUserName
      -- Switch UID/GID if needed, and update user's home directory
      case de.user of
        Nothing -> pure ()
        Just (DockerUser 0 _ _ _) -> pure ()
        Just du -> withProcessContext envOverride $
          updateOrCreateStackUser estackUserEntry0 homeDir du
      case estackUserEntry0 of
        Left _ -> pure ()
        Right ue -> do
          -- If the 'stack' user exists in the image, copy any build plans and
          -- package indices from its original home directory to the host's
          -- Stack root, to avoid needing to download them
          origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue)
          let origStackRoot = origStackHomeDir </> relDirDotStackProgName
          buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)
          when buildPlanDirExists $ do
            (_, buildPlans) <- listDir (buildPlanDir origStackRoot)
            forM_ buildPlans $ \srcBuildPlan -> do
              let destBuildPlan =
                    buildPlanDir (view stackRootL config) </> filename srcBuildPlan
              exists <- doesFileExist destBuildPlan
              unless exists $ do
                ensureDir (parent destBuildPlan)
                copyFile srcBuildPlan destBuildPlan
    pure True
 where
  updateOrCreateStackUser estackUserEntry homeDir du = do
    case estackUserEntry of
      Left _ -> do
        -- If no 'stack' user in image, create one with correct UID/GID and home
        -- directory
        readProcessNull "groupadd"
          [ "-o"
          , "--gid",show du.gid
          , stackUserName
          ]
        readProcessNull "useradd"
          [ "-oN"
          , "--uid", show du.uid
          , "--gid", show du.gid
          , "--home", toFilePathNoTrailingSep homeDir
          , stackUserName
          ]
      Right _ -> do
        -- If there is already a 'stack' user in the image, adjust its UID/GID
        -- and home directory
        readProcessNull "usermod"
          [ "-o"
          , "--uid", show du.uid
          , "--home", toFilePathNoTrailingSep homeDir
          , stackUserName
          ]
        readProcessNull "groupmod"
          [ "-o"
          , "--gid", show du.gid
          , stackUserName
          ]
    forM_ du.groups $ \gid ->
      readProcessNull "groupadd"
        [ "-o"
        , "--gid", show gid
        , "group" ++ show gid
        ]
    -- 'setuid' to the wanted UID and GID
    liftIO $ do
      User.setGroupID du.gid
      handleSetGroups du.groups
      User.setUserID du.uid
      _ <- Files.setFileCreationMask du.umask
      pure ()
  stackUserName = "stack" :: String

-- | Remove the contents of a directory, without removing the directory itself.
-- This is used instead of 'FS.removeTree' to clear bind-mounted directories,
-- since removing the root of the bind-mount won't work.
removeDirectoryContents ::
     Path Abs Dir -- ^ Directory to remove contents of
  -> [Path Rel Dir] -- ^ Top-level directory names to exclude from removal
  -> [Path Rel File] -- ^ Top-level file names to exclude from removal
  -> IO ()
removeDirectoryContents path excludeDirs excludeFiles = do
  isRootDir <- doesDirExist path
  when isRootDir $ do
    (lsd,lsf) <- listDir path
    forM_ lsd
          (\d -> unless (dirname d `elem` excludeDirs)
                        (removeDirRecur d))
    forM_ lsf
          (\f -> unless (filename f `elem` excludeFiles)
                        (removeFile f))

-- | Produce a strict 'S.ByteString' from the stdout of a process. Throws a
-- 'ReadProcessException' exception if the process fails.
--
-- The stderr output is passed straight through, which is desirable for some
-- cases e.g. docker pull, in which docker uses stderr for progress output.
--
-- Use 'readProcess_' directly to customize this.
readDockerProcess ::
     (HasProcessContext env, HasLogFunc env)
  => [String] -> RIO env BS.ByteString
readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_

-- | Name of home directory within docker sandbox.
homeDirName :: Path Rel Dir
homeDirName = relDirUnderHome

-- | Directory where 'stack' executable is bind-mounted in Docker container
-- This refers to a path in the Linux *container*, and so should remain a
-- 'FilePath' (not 'Path Abs Dir') so that it works when the host runs Windows.
hostBinDir :: FilePath
hostBinDir = "/opt/host/bin"

-- | Convenience function to decode ByteString to String.
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 bs = T.unpack (T.decodeUtf8 bs)

-- | Fail with friendly error if project root not set.
getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)
getProjectRoot = do
  mroot <- view $ configL . to configProjectRoot
  maybe (throwIO CannotDetermineProjectRootException) pure mroot

-- | Environment variable that contained the old sandbox ID.
-- | Use of this variable is deprecated, and only used to detect old images.
oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"

-- | Parsed result of @docker inspect@.
data Inspect = Inspect
  { config      :: ImageConfig
  , created     :: UTCTime
  , iiId        :: Text
  , virtualSize :: Maybe Integer
  }
  deriving Show

-- | Parse @docker inspect@ output.
instance FromJSON Inspect where
  parseJSON v = do
    o <- parseJSON v
    Inspect
      <$> o .: "Config"
      <*> o .: "Created"
      <*> o .: "Id"
      <*> o .:? "VirtualSize"

-- | Parsed @Config@ section of @docker inspect@ output.
data ImageConfig = ImageConfig
  { env :: [String]
  , entrypoint :: [String]
  }
  deriving Show

-- | Parse @Config@ section of @docker inspect@ output.
instance FromJSON ImageConfig where
  parseJSON v = do
    o <- parseJSON v
    ImageConfig
      <$> fmap join (o .:? "Env") .!= []
      <*> fmap join (o .:? "Entrypoint") .!= []