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

{-|
Module      : Stack.Docker
Description : Run commands in Docker containers.
License     : BSD-3-Clause

Run commands in Docker containers.
-}

module Stack.Docker
  ( dockerCmdName
  , dockerHelpOptName
  , dockerPullCmdName
  , entrypoint
  , preventInContainer
  , pull
  , reset
  , reExecArgName
  , DockerException (..)
  , getProjectRoot
  , runContainerAndExit
  ) where

import           Control.Monad.Extra ( whenJust )
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
                   )
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 (..), progNameL, terminalL
                   , viewExecutablePath
                   )
import           Stack.Types.Version ( showStackVersion, withinRange )
import           System.Environment ( getArgs, getEnv, getEnvironment )
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 :: forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker = do
    config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
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 DockerStackExe
DockerStackExeHost
          | Config
config.platform Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              exePath <- RIO env (Path Abs File)
forall env. HasRunner env => RIO env (Path Abs File)
viewExecutablePath
              cmdArgs args exePath
          | Bool
otherwise -> DockerException
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
UnsupportedStackExeHostPlatformException
        Just DockerStackExe
DockerStackExeImage -> do
            progName <- Getting FilePath env FilePath -> RIO env FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath env FilePath
forall env. HasRunner env => SimpleGetter env FilePath
SimpleGetter env FilePath
progNameL
            pure (FP.takeBaseName progName, args, [], [])
        Just (DockerStackExePath Path Abs File
path) -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
path
        Just DockerStackExe
DockerStackExeDownload -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
        Maybe DockerStackExe
Nothing
          | Config
config.platform Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              (exePath, exeTimestamp, misCompatible) <-
                  do exePath <- RIO env (Path Abs File)
forall env. HasRunner env => RIO env (Path Abs File)
viewExecutablePath
                     exeTimestamp <- getModificationTime exePath
                     isKnown <-
                         loadDockerImageExeCache
                             imageInfo.iiId
                             exePath
                             exeTimestamp
                     pure (exePath, exeTimestamp, isKnown)
              case misCompatible of
                  Just Bool
True -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
                  Just Bool
False -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
                  Maybe Bool
Nothing -> do
                      e <-
                          RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ()))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ())))
-> RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ()))
forall a b. (a -> b) -> a -> b
$
                          FilePath
-> [FilePath]
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
-> RIO env ((), ())
forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath
-> [FilePath]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout
                              FilePath
"docker"
                              [ FilePath
"run"
                              , FilePath
"-v"
                              , Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/tmp/stack"
                              , Text -> FilePath
T.unpack Inspect
imageInfo.iiId
                              , FilePath
"/tmp/stack"
                              , FilePath
"--version"]
                              ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
                              ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
                      let compatible =
                              case Either ExitCodeException ((), ())
e of
                                  Left ExitCodeException{} -> Bool
False
                                  Right ((), ())
_ -> Bool
True
                      saveDockerImageExeCache
                          imageInfo.iiId
                          exePath
                          exeTimestamp
                          compatible
                      if compatible
                          then cmdArgs args exePath
                          else exeDownload args
        Maybe DockerStackExe
Nothing -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
  where
    exeDownload :: b -> RIO env (FilePath, b, [a], [Mount])
exeDownload b
args = do
        exePath <- Platform -> RIO env (Path Abs File)
forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
dockerContainerPlatform
        cmdArgs args exePath
    cmdArgs :: b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path b File
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 :: Path b File
exeBase =
              case Path b File -> Either SomeException (Path b File, FilePath)
forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
splitExtension Path b File
exePath of
                Left SomeException
_ -> Path b File
exePath
                Right (Path b File
x, FilePath
_) -> Path b File
x
        let mountPath :: FilePath
mountPath = FilePath
hostBinDir FilePath -> FilePath -> FilePath
FP.</> Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b File
exeBase)
        (FilePath, b, [a], [Mount]) -> f (FilePath, b, [a], [Mount])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
mountPath, b
args, [], [FilePath -> FilePath -> Mount
Mount (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
exePath) FilePath
mountPath])

-- | Error if running in a container.

preventInContainer :: MonadIO m => m () -> m ()
preventInContainer :: forall (m :: * -> *). MonadIO m => m () -> m ()
preventInContainer m ()
inner =
  do inContainer <- m Bool
forall (m :: * -> *). MonadIO m => m Bool
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 :: forall env void. HasConfig env => RIO env void
runContainerAndExit = do
  config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  let docker = Config
config.docker
  checkDockerVersion docker
  (env, isStdinTerminal, isStderrTerminal, homeDir) <- liftIO $
    (,,,)
    <$> getEnvironment
    <*> hIsTerminalDeviceOrMinTTY stdin
    <*> hIsTerminalDeviceOrMinTTY stderr
    <*> getHomeDir
  isStdoutTerminal <- view terminalL
  let dockerHost = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_HOST" [(FilePath, FilePath)]
env
      dockerCertPath = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_CERT_PATH" [(FilePath, FilePath)]
env
      msshAuthSock = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"SSH_AUTH_SOCK" [(FilePath, FilePath)]
env
      muserEnv = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"USER" [(FilePath, FilePath)]
env
      isRemoteDocker = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"tcp://") Maybe FilePath
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."
    )
  imageInfo <- inspect image >>= \case
    Just Inspect
ii -> Inspect -> RIO env Inspect
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii
    Maybe Inspect
Nothing
      | DockerOpts
docker.autoPull -> do
          DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasTerm env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image
          FilePath -> RIO env (Maybe Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image RIO env (Maybe Inspect)
-> (Maybe Inspect -> RIO env Inspect) -> RIO env Inspect
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Inspect
ii2 -> Inspect -> RIO env Inspect
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii2
            Maybe Inspect
Nothing -> DockerException -> RIO env Inspect
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (FilePath -> DockerException
InspectFailedException FilePath
image)
      | Bool
otherwise -> DockerException -> RIO env Inspect
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (FilePath -> DockerException
NotPulledException FilePath
image)
  projectRoot <- getProjectRoot
  sandboxDir <- projectDockerSandboxDir projectRoot
  let ic = Inspect
imageInfo.config
      imageEnvVars = (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')) ImageConfig
ic.env
      platformVariant = Digest MD5 -> FilePath
forall a. Show a => a -> FilePath
show (Digest MD5 -> FilePath) -> Digest MD5 -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Digest MD5
hashRepoName FilePath
image
      stackRoot = Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' Config (Path Abs Dir)
stackRootL Config
config
      sandboxHomeDir = Path Abs Dir
sandboxDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
homeDirName
      isTerm = Bool
isStdinTerminal Bool -> Bool -> Bool
&& Bool
isStdoutTerminal Bool -> Bool -> Bool
&& Bool
isStderrTerminal
      allocatePseudoTty = Bool -> Bool
not DockerOpts
docker.detach Bool -> Bool -> Bool
&& Bool
isTerm
      keepStdinOpen = Bool -> Bool
not DockerOpts
docker.detach
  let mpath = FilePath -> Text
T.pack (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall {a}. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
"PATH" [(FilePath, FilePath)]
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 = Path Abs Dir
homeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
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 = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) DockerOpts
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
            Maybe FilePath
Nothing -> [FilePath
"--net=host"]
            Just FilePath
name -> [FilePath
"--net=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
        , case muserEnv of
            Maybe FilePath
Nothing -> []
            Just FilePath
userEnv -> [FilePath
"-e",FilePath
"USER=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
userEnv]
        , case msshAuthSock of
            Maybe FilePath
Nothing -> []
            Just FilePath
sshAuthSock ->
              [ FilePath
"-e",FilePath
"SSH_AUTH_SOCK=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock
              , FilePath
"-v",FilePath
sshAuthSock FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock
              ]
        , case mstackYaml of
            Maybe FilePath
Nothing -> []
            Just FilePath
stackYaml ->
              [ FilePath
"-e",FilePath
"STACK_YAML=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml
              , FilePath
"-v",FilePath
stackYamlFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":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 (\(FilePath
k,FilePath
v) -> [FilePath
"-e", FilePath
k FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
v]) envVars
        , concatMap (mountArg mountSuffix) (extraMount ++ docker.mount)
        , concatMap (\FilePath
nv -> [FilePath
"-e", FilePath
nv]) docker.env
        , case docker.containerName of
            Just FilePath
name -> [FilePath
"--name=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
            Maybe FilePath
Nothing -> []
        , ["-t" | allocatePseudoTty]
        , ["-i" | keepStdinOpen]
        , docker.runArgs
        , [image]
        , [cmnd]
        , args
        ]
      )
  handleSignals docker keepStdinOpen containerID >>= \case
    Left ExitCodeException{ExitCode
eceExitCode :: ExitCode
eceExitCode :: ExitCodeException -> ExitCode
eceExitCode} -> ExitCode -> RIO env void
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith ExitCode
eceExitCode
    Right () -> RIO env void
forall (m :: * -> *) a. MonadIO m => m a
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 :: FilePath -> Digest MD5
hashRepoName = ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (ByteString -> Digest MD5)
-> (FilePath -> ByteString) -> FilePath -> Digest MD5
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BS.pack (FilePath -> ByteString)
-> (FilePath -> FilePath) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@')
  lookupImageEnv :: a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv a
name [(a, FilePath)]
vars =
    case a -> [(a, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, FilePath)]
vars of
      Just (Char
'=':FilePath
val) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
val
      Maybe FilePath
_ -> Maybe FilePath
forall a. Maybe a
Nothing
  mountArg :: FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix (Mount FilePath
host FilePath
container) =
    [FilePath
"-v",FilePath
host FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
container FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix]
  sshRelDir :: Path Rel Dir
sshRelDir = Path Rel Dir
relDirDotSsh

-- | Inspect Docker image or container.

inspect ::
     (HasProcessContext env, HasLogFunc env)
  => String
  -> RIO env (Maybe Inspect)
inspect :: forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image = do
  results <- [FilePath] -> RIO env (Map Text Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [FilePath
image]
  case Map.toList results of
    [] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inspect
forall a. Maybe a
Nothing
    [(Text
_,Inspect
i)] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Inspect -> Maybe Inspect
forall a. a -> Maybe a
Just Inspect
i)
    [(Text, Inspect)]
_ -> DockerException -> RIO env (Maybe Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
InvalidInspectOutputException FilePath
"expect a single result")

-- | Inspect multiple Docker images and/or containers.

inspects ::
     (HasProcessContext env, HasLogFunc env)
  => [String]
  -> RIO env (Map Text Inspect)
inspects :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [] = Map Text Inspect -> RIO env (Map Text Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Inspect
forall k a. Map k a
Map.empty
inspects [FilePath]
images = do
  maybeInspectOut <-
    -- not using 'readDockerProcess' as the error from a missing image

    -- needs to be recovered.

    RIO env ByteString -> RIO env (Either ExitCodeException ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString)
-> ((LazyByteString, LazyByteString) -> LazyByteString)
-> (LazyByteString, LazyByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LazyByteString, LazyByteString) -> LazyByteString
forall a b. (a, b) -> a
fst ((LazyByteString, LazyByteString) -> ByteString)
-> RIO env (LazyByteString, LazyByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () ()
    -> RIO env (LazyByteString, LazyByteString))
-> RIO env (LazyByteString, LazyByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" (FilePath
"inspect" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
images) ProcessConfig () () () -> RIO env (LazyByteString, LazyByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (LazyByteString, LazyByteString)
readProcess_)
  case maybeInspectOut of
    Right ByteString
inspectOut ->
      -- filtering with 'isAscii' to workaround @docker inspect@ output

      -- containing invalid UTF-8

      case LazyByteString -> Either FilePath [Inspect]
forall a. FromJSON a => LazyByteString -> Either FilePath a
eitherDecode (FilePath -> LazyByteString
LBS.pack ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAscii (ByteString -> FilePath
decodeUtf8 ByteString
inspectOut))) of
        Left FilePath
msg -> DockerException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
InvalidInspectOutputException FilePath
msg)
        Right [Inspect]
results -> Map Text Inspect -> RIO env (Map Text Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Inspect)] -> Map Text Inspect
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Inspect -> (Text, Inspect)) -> [Inspect] -> [(Text, Inspect)]
forall a b. (a -> b) -> [a] -> [b]
map (\Inspect
r -> (Inspect
r.iiId, Inspect
r)) [Inspect]
results))
    Left ExitCodeException
ece
      | (LazyByteString -> Bool) -> [LazyByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (LazyByteString -> LazyByteString -> Bool
`LBS.isPrefixOf` ExitCodeException -> LazyByteString
eceStderr ExitCodeException
ece) [LazyByteString]
missingImagePrefixes ->
          Map Text Inspect -> RIO env (Map Text Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Inspect
forall k a. Map k a
Map.empty
    Left ExitCodeException
e -> ExitCodeException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCodeException
e
 where
  missingImagePrefixes :: [LazyByteString]
missingImagePrefixes = [LazyByteString
"Error: No such image", LazyByteString
"Error: No such object:"]

-- | Pull latest version of configured Docker image from registry.

pull :: HasConfig env => RIO env ()
pull :: forall env. HasConfig env => RIO env ()
pull = do
  config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  let docker = Config
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 :: forall env.
(HasProcessContext env, HasTerm env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image = do
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Pulling image from registry:"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
image) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when DockerOpts
docker.registryLogin (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyInfoS FilePath
"You may need to log in."
    FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc
      FilePath
"docker"
      ( [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [FilePath
"login"]
          , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
n -> [FilePath
"--username=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
n]) DockerOpts
docker.registryUsername
          , [FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
p -> [FilePath
"--password=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p]) DockerOpts
docker.registryPassword
          , [(Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') FilePath
image]
          ]
      )
      ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
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 <- FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath
"pull", FilePath
image] ((ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode)
-> (ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
    let pc :: ProcessConfig () () ()
pc = StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
           (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
           (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed
             ProcessConfig () () ()
pc0
    ProcessConfig () () () -> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
pc
  case ec of
    ExitCode
ExitSuccess -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExitFailure Int
_ -> DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
PullFailedException FilePath
image)

-- | Check docker version (throws exception if incorrect)

checkDockerVersion ::
     (HasProcessContext env, HasLogFunc env)
  => DockerOpts
  -> RIO env ()
checkDockerVersion :: forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker = do
  dockerExists <- FilePath -> RIO env Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
FilePath -> m Bool
doesExecutableExist FilePath
"docker"
  unless dockerExists (throwIO DockerNotInstalledException)
  dockerVersionOut <- readDockerProcess ["--version"]
  case words (decodeUtf8 dockerVersionOut) of
    (FilePath
_:FilePath
_:FilePath
v:[FilePath]
_) ->
      case (Version -> Version) -> Maybe Version -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> Version
mkVersion' (Maybe Version -> Maybe Version) -> Maybe Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Version
parseVersion' (FilePath -> Maybe Version) -> FilePath -> Maybe Version
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
stripVersion FilePath
v of
        Just Version
v'
          | Version
v' Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
minimumDockerVersion ->
            DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> DockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
          | Version
v' Version -> [Version] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
forall a. [a]
prohibitedDockerVersions ->
            DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> DockerException
DockerVersionProhibitedException [Version]
forall a. [a]
prohibitedDockerVersions Version
v')
          | Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts
docker.requireDockerVersion) ->
            DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (VersionRange -> Version -> DockerException
BadDockerVersionException DockerOpts
docker.requireDockerVersion Version
v')
          | Bool
otherwise ->
            () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe Version
_ -> DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
    [FilePath]
_ -> DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
 where
  minimumDockerVersion :: Version
minimumDockerVersion = [Int] -> Version
mkVersion [Int
1, Int
6, Int
0]
  prohibitedDockerVersions :: [a]
prohibitedDockerVersions = []
  stripVersion :: FilePath -> FilePath
stripVersion FilePath
v = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) FilePath
v)
  -- version is parsed by Data.Version provided code to avoid

  -- Cabal's Distribution.Version lack of support for leading zeros in version

  parseVersion' :: FilePath -> Maybe Version
parseVersion' =
    ((Version, FilePath) -> Version)
-> Maybe (Version, FilePath) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version, FilePath) -> Version
forall a b. (a, b) -> a
fst (Maybe (Version, FilePath) -> Maybe Version)
-> (FilePath -> Maybe (Version, FilePath))
-> FilePath
-> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Version, FilePath)] -> Maybe (Version, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Version, FilePath)] -> Maybe (Version, FilePath))
-> (FilePath -> [(Version, FilePath)])
-> FilePath
-> Maybe (Version, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Version, FilePath)] -> [(Version, FilePath)]
forall a. [a] -> [a]
reverse ([(Version, FilePath)] -> [(Version, FilePath)])
-> (FilePath -> [(Version, FilePath)])
-> FilePath
-> [(Version, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> FilePath -> [(Version, FilePath)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
Data.Version.parseVersion

-- | Remove the project's Docker sandbox.

reset :: HasConfig env => Bool -> RIO env ()
reset :: forall env. HasConfig env => Bool -> RIO env ()
reset Bool
keepHome = do
  projectRoot <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
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 :: forall env.
(HasDockerEntrypointMVar env, HasProcessContext env,
 HasLogFunc env) =>
Config -> DockerEntrypoint -> RIO env ()
entrypoint config :: Config
config@Config{} DockerEntrypoint
de = do
  entrypointMVar <- Getting (MVar Bool) env (MVar Bool) -> RIO env (MVar Bool)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MVar Bool) env (MVar Bool)
forall env. HasDockerEntrypointMVar env => Lens' env (MVar Bool)
Lens' env (MVar Bool)
dockerEntrypointMVarL
  modifyMVar_ entrypointMVar $ \Bool
alreadyRan -> do
    -- Only run the entrypoint once

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyRan (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      envOverride <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
Lens' env ProcessContext
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

      whenJust de.user $ \DockerUser
du -> case DockerUser
du of
        DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        DockerUser
_ -> ProcessContext -> RIO env () -> RIO env ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
envOverride (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          Either () UserEntry -> Path Abs Dir -> DockerUser -> RIO env ()
forall {env} {r} {a} {b} {loc}.
(HasProcessContext env, HasLogFunc env, HasField "uid" r UserID,
 HasField "gid" r GroupID, HasField "groups" r [GroupID],
 HasField "umask" r FileMode) =>
Either a b -> Path loc Dir -> r -> RIO env ()
updateOrCreateStackUser Either () UserEntry
estackUserEntry0 Path Abs Dir
homeDir DockerUser
du
      case estackUserEntry0 of
        Left ()
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right UserEntry
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 <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> RIO env (Path Abs Dir))
-> IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (UserEntry -> FilePath
User.homeDirectory UserEntry
ue)
          let origStackRoot = Path Abs Dir
origStackHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotStackProgName
          buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)
          when buildPlanDirExists $ do
            (_, buildPlans) <- listDir (buildPlanDir origStackRoot)
            forM_ buildPlans $ \Path Abs File
srcBuildPlan -> do
              let destBuildPlan :: Path Abs File
destBuildPlan =
                    Path Abs Dir -> Path Abs Dir
buildPlanDir (Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
Lens' Config (Path Abs Dir)
stackRootL Config
config) Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
srcBuildPlan
              exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
destBuildPlan
              unless exists $ do
                ensureDir (parent destBuildPlan)
                copyFile srcBuildPlan destBuildPlan
    Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
 where
  updateOrCreateStackUser :: Either a b -> Path loc Dir -> r -> RIO env ()
updateOrCreateStackUser Either a b
estackUserEntry Path loc Dir
homeDir r
du = do
    case Either a b
estackUserEntry of
      Left a
_ -> do
        -- If no 'stack' user in image, create one with correct UID/GID and home

        -- directory

        FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupadd"
          [ FilePath
"-o"
          , FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show r
du.gid
          , FilePath
stackUserName
          ]
        FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"useradd"
          [ FilePath
"-oN"
          , FilePath
"--uid", UserID -> FilePath
forall a. Show a => a -> FilePath
show r
du.uid
          , FilePath
"--gid", GroupID -> FilePath
forall a. Show a => a -> FilePath
show r
du.gid
          , FilePath
"--home", Path loc Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path loc Dir
homeDir
          , FilePath
stackUserName
          ]
      Right b
_ -> do
        -- If there is already a 'stack' user in the image, adjust its UID/GID

        -- and home directory

        FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"usermod"
          [ FilePath
"-o"
          , FilePath
"--uid", UserID -> FilePath
forall a. Show a => a -> FilePath
show r
du.uid
          , FilePath
"--home", Path loc Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path loc Dir
homeDir
          , FilePath
stackUserName
          ]
        FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupmod"
          [ FilePath
"-o"
          , FilePath
"--gid", GroupID -> FilePath
forall a. Show a => a -> FilePath
show r
du.gid
          , FilePath
stackUserName
          ]
    [GroupID] -> (GroupID -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ r
du.groups ((GroupID -> RIO env ()) -> RIO env ())
-> (GroupID -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \GroupID
gid ->
      FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupadd"
        [ FilePath
"-o"
        , FilePath
"--gid", GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
gid
        , FilePath
"group" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
gid
        ]
    -- 'setuid' to the wanted UID and GID

    IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      GroupID -> IO ()
User.setGroupID r
du.gid
      [GroupID] -> IO ()
handleSetGroups r
du.groups
      UserID -> IO ()
User.setUserID r
du.uid
      IO FileMode -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO FileMode -> IO ()) -> IO FileMode -> IO ()
forall a b. (a -> b) -> a -> b
$ FileMode -> IO FileMode
Files.setFileCreationMask r
du.umask
  stackUserName :: FilePath
stackUserName = FilePath
"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 Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> IO ()
removeDirectoryContents Path Abs Dir
path [Path Rel Dir]
excludeDirs [Path Rel File]
excludeFiles = do
  isRootDir <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
path
  when isRootDir $ do
    (lsd,lsf) <- listDir path
    forM_ lsd
          (\Path Abs Dir
d -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
d Path Rel Dir -> [Path Rel Dir] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel Dir]
excludeDirs)
                        (Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
d))
    forM_ lsf
          (\Path Abs File
f -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
f Path Rel File -> [Path Rel File] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel File]
excludeFiles)
                        (Path Abs File -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
f))

-- | Produce a strict 'S.ByteString' from the stdout of a process. Throws a

-- 'Rio.Process.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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath]
args = LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString)
-> RIO env LazyByteString -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env LazyByteString)
-> RIO env LazyByteString
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath]
args ProcessConfig () () () -> RIO env LazyByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m LazyByteString
readProcessStdout_

-- | Name of home directory within docker sandbox.

homeDirName :: Path Rel Dir
homeDirName :: Path Rel Dir
homeDirName = Path Rel Dir
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 :: FilePath
hostBinDir = FilePath
"/opt/host/bin"

-- | Convenience function to decode ByteString to String.

decodeUtf8 :: BS.ByteString -> String
decodeUtf8 :: ByteString -> FilePath
decodeUtf8 ByteString
bs = Text -> FilePath
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
bs)

-- | Fail with friendly error if project root not set.

getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)
getProjectRoot :: forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot = do
  mroot <- Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
-> RIO env (Maybe (Path Abs Dir))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
 -> RIO env (Maybe (Path Abs Dir)))
-> Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
-> RIO env (Maybe (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe (Path Abs Dir)) Config)
-> env -> Const (Maybe (Path Abs Dir)) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const (Maybe (Path Abs Dir)) Config)
 -> env -> Const (Maybe (Path Abs Dir)) env)
-> ((Maybe (Path Abs Dir)
     -> Const (Maybe (Path Abs Dir)) (Maybe (Path Abs Dir)))
    -> Config -> Const (Maybe (Path Abs Dir)) Config)
-> Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Maybe (Path Abs Dir))
-> SimpleGetter Config (Maybe (Path Abs Dir))
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe (Path Abs Dir)
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 :: FilePath
oldSandboxIdEnvVar = FilePath
"DOCKER_SANDBOX_ID"

-- | Parsed result of @docker inspect@.

data Inspect = Inspect
  { Inspect -> ImageConfig
config      :: ImageConfig
  , Inspect -> UTCTime
created     :: UTCTime
  , Inspect -> Text
iiId        :: Text
  , Inspect -> Maybe Integer
virtualSize :: Maybe Integer
  }
  deriving Int -> Inspect -> FilePath -> FilePath
[Inspect] -> FilePath -> FilePath
Inspect -> FilePath
(Int -> Inspect -> FilePath -> FilePath)
-> (Inspect -> FilePath)
-> ([Inspect] -> FilePath -> FilePath)
-> Show Inspect
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> Inspect -> FilePath -> FilePath
showsPrec :: Int -> Inspect -> FilePath -> FilePath
$cshow :: Inspect -> FilePath
show :: Inspect -> FilePath
$cshowList :: [Inspect] -> FilePath -> FilePath
showList :: [Inspect] -> FilePath -> FilePath
Show

-- | Parse @docker inspect@ output.

instance FromJSON Inspect where
  parseJSON :: Value -> Parser Inspect
parseJSON Value
v = do
    o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    Inspect
      <$> o .: "Config"
      <*> o .: "Created"
      <*> o .: "Id"
      <*> o .:? "VirtualSize"

-- | Parsed @Config@ section of @docker inspect@ output.

data ImageConfig = ImageConfig
  { ImageConfig -> [FilePath]
env :: [String]
  , ImageConfig -> [FilePath]
entrypoint :: [String]
  }
  deriving Int -> ImageConfig -> FilePath -> FilePath
[ImageConfig] -> FilePath -> FilePath
ImageConfig -> FilePath
(Int -> ImageConfig -> FilePath -> FilePath)
-> (ImageConfig -> FilePath)
-> ([ImageConfig] -> FilePath -> FilePath)
-> Show ImageConfig
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ImageConfig -> FilePath -> FilePath
showsPrec :: Int -> ImageConfig -> FilePath -> FilePath
$cshow :: ImageConfig -> FilePath
show :: ImageConfig -> FilePath
$cshowList :: [ImageConfig] -> FilePath -> FilePath
showList :: [ImageConfig] -> FilePath -> FilePath
Show

-- | Parse @Config@ section of @docker inspect@ output.

instance FromJSON ImageConfig where
  parseJSON :: Value -> Parser ImageConfig
parseJSON Value
v = do
    o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    ImageConfig
      <$> fmap join (o .:? "Env") .!= []
      <*> fmap join (o .:? "Entrypoint") .!= []