{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import           Stack.Prelude
import qualified Crypto.Hash as Hash (Digest, MD5, hash)
import           Pantry.Internal.AesonExtended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
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.Conduit.Process.Typed hiding (proc)
import           Data.List (dropWhileEnd,isPrefixOf,isInfixOf)
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 (showVersion, parseVersion)
import           Distribution.Version (mkVersion, mkVersion')
import           Path
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO hiding (canonicalizePath)
import qualified Paths_stack as Meta
import           Stack.Config (getInContainer)
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Setup (ensureDockerStackExe)
import           Stack.Storage.User (loadDockerImageExeCache,saveDockerImageExeCache)
import           Stack.Types.Version
import           Stack.Types.Config
import           Stack.Types.Docker
import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)
import qualified System.FilePath as FP
import           System.IO.Error (isDoesNotExistError)
import           System.IO.Unsafe (unsafePerformIO)
import qualified System.PosixCompat.User as User
import qualified System.PosixCompat.Files as Files
import           System.Terminal (hIsTerminalDeviceOrMinTTY)
import           Text.ParserCombinators.ReadP (readP_to_S)
import           RIO.Process
import qualified RIO.Directory

#ifndef WINDOWS
import           System.Posix.Signals
import qualified System.Posix.User as PosixUser
#endif

-- | 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 :: DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker = do
    Config
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
configL
    Maybe DockerUser
deUser <-
        if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not Bool
isRemoteDocker) (DockerOpts -> Maybe Bool
dockerSetUser DockerOpts
docker)
            then IO (Maybe DockerUser) -> RIO env (Maybe DockerUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DockerUser) -> RIO env (Maybe DockerUser))
-> IO (Maybe DockerUser) -> RIO env (Maybe DockerUser)
forall a b. (a -> b) -> a -> b
$ do
              UserID
duUid <- IO UserID
User.getEffectiveUserID
              GroupID
duGid <- IO GroupID
User.getEffectiveGroupID
              [GroupID]
duGroups <- [GroupID] -> [GroupID]
forall a. Ord a => [a] -> [a]
nubOrd ([GroupID] -> [GroupID]) -> IO [GroupID] -> IO [GroupID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [GroupID]
User.getGroups
              FileMode
duUmask <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
0o022
              -- Only way to get old umask seems to be to change it, so set it back afterward
              FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
              Maybe DockerUser -> IO (Maybe DockerUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (DockerUser -> Maybe DockerUser
forall a. a -> Maybe a
Just DockerUser :: UserID -> GroupID -> [GroupID] -> FileMode -> DockerUser
DockerUser{[GroupID]
FileMode
GroupID
UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
..})
            else Maybe DockerUser -> RIO env (Maybe DockerUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DockerUser
forall a. Maybe a
Nothing
    [FilePath]
args <-
        ([FilePath] -> [FilePath])
-> RIO env [FilePath] -> RIO env [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ([FilePath
"--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
reExecArgName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
Data.Version.showVersion Version
Meta.version
             ,FilePath
"--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dockerEntrypointArgName
             ,DockerEntrypoint -> FilePath
forall a. Show a => a -> FilePath
show DockerEntrypoint :: Maybe DockerUser -> DockerEntrypoint
DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: Maybe DockerUser
..}] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++)
            (IO [FilePath] -> RIO env [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getArgs)
    case DockerOpts -> Maybe DockerStackExe
dockerStackExe (Config -> DockerOpts
configDocker Config
config) of
        Just DockerStackExe
DockerStackExeHost
          | Config -> Platform
configPlatform Config
config Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              Path Abs File
exePath <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' (FilePath -> RIO env (Path Abs File))
-> RIO env FilePath -> RIO env (Path Abs File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
              [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
          | Bool
otherwise -> StackDockerException
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
UnsupportedStackExeHostPlatformException
        Just DockerStackExe
DockerStackExeImage -> do
            FilePath
progName <- IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getProgName
            (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
        Just (DockerStackExePath Path Abs File
path) -> do
            [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (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 -> Platform
configPlatform Config
config Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              (Path Abs File
exePath,UTCTime
exeTimestamp,Maybe Bool
misCompatible) <-
                  do Path Abs File
exePath <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' (FilePath -> RIO env (Path Abs File))
-> RIO env FilePath -> RIO env (Path Abs File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
                     UTCTime
exeTimestamp <- Path Abs File -> RIO env UTCTime
forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path Abs File
exePath
                     Maybe Bool
isKnown <-
                         Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache
                             (Inspect -> Text
iiId Inspect
imageInfo)
                             Path Abs File
exePath
                             UTCTime
exeTimestamp
                     (Path Abs File, UTCTime, Maybe Bool)
-> RIO env (Path Abs File, UTCTime, Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs File
exePath, UTCTime
exeTimestamp, Maybe Bool
isKnown)
              case Maybe Bool
misCompatible of
                  Just Bool
True -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (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
                      Either ExitCodeException ((), ())
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 -> Text
iiId Inspect
imageInfo)
                              , 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 :: Bool
compatible =
                              case Either ExitCodeException ((), ())
e of
                                  Left ExitCodeException{} -> Bool
False
                                  Right ((), ())
_ -> Bool
True
                      Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
saveDockerImageExeCache
                          (Inspect -> Text
iiId Inspect
imageInfo)
                          Path Abs File
exePath
                          UTCTime
exeTimestamp
                          Bool
compatible
                      if Bool
compatible
                          then [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
                          else [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 -> [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
        Path Abs File
exePath <- Platform -> RIO env (Path Abs File)
forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
dockerContainerPlatform
        b -> Path Abs File -> RIO env (FilePath, b, [a], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs b
args Path Abs File
exePath
    cmdArgs :: b -> Path b File -> m (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
#if MIN_VERSION_path(0, 7, 0)
        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
#else
        exeBase <- exePath -<.> ""
#endif
        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]) -> m (FilePath, b, [a], [Mount])
forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: m () -> m ()
preventInContainer m ()
inner =
  do Bool
inContainer <- m Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer
     if Bool
inContainer
        then StackDockerException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
OnlyOnHostException
        else m ()
inner

-- | Run a command in a new Docker container, then exit the process.
runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit :: RIO env void
runContainerAndExit = do
     Config
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
configL
     let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
     DockerOpts -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
     ([(FilePath, FilePath)]
env,Bool
isStdinTerminal,Bool
isStderrTerminal,Path Abs Dir
homeDir) <- IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
-> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
 -> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
-> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
       (,,,)
       ([(FilePath, FilePath)]
 -> Bool
 -> Bool
 -> Path Abs Dir
 -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO [(FilePath, FilePath)]
-> IO
     (Bool
      -> Bool
      -> Path Abs Dir
      -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
       IO
  (Bool
   -> Bool
   -> Path Abs Dir
   -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO Bool
-> IO
     (Bool
      -> Path Abs Dir
      -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stdin
       IO
  (Bool
   -> Path Abs Dir
   -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO Bool
-> IO
     (Path Abs Dir
      -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stderr
       IO
  (Path Abs Dir
   -> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO (Path Abs Dir)
-> IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
     Bool
isStdoutTerminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => Lens' env Bool
terminalL
     let dockerHost :: Maybe FilePath
dockerHost = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_HOST" [(FilePath, FilePath)]
env
         dockerCertPath :: Maybe FilePath
dockerCertPath = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_CERT_PATH" [(FilePath, FilePath)]
env
         bamboo :: Maybe FilePath
bamboo = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"bamboo_buildKey" [(FilePath, FilePath)]
env
         jenkins :: Maybe FilePath
jenkins = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"JENKINS_HOME" [(FilePath, FilePath)]
env
         msshAuthSock :: Maybe FilePath
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 :: Maybe FilePath
muserEnv = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"USER" [(FilePath, FilePath)]
env
         isRemoteDocker :: Bool
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
     Maybe FilePath
mstackYaml <- Maybe FilePath
-> (FilePath -> RIO env FilePath) -> RIO env (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"STACK_YAML" [(FilePath, FilePath)]
env) FilePath -> RIO env FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
RIO.Directory.makeAbsolute
     FilePath
image <- (SomeException -> RIO env FilePath)
-> (FilePath -> RIO env FilePath)
-> Either SomeException FilePath
-> RIO env FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env FilePath
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO FilePath -> RIO env FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)
     Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isRemoteDocker Bool -> Bool -> Bool
&&
           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
isInfixOf FilePath
"boot2docker") Maybe FilePath
dockerCertPath)
          (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Warning: Using boot2docker is NOT supported, and not likely to perform well.")
     Maybe Inspect
maybeImageInfo <- FilePath -> RIO env (Maybe Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
     imageInfo :: Inspect
imageInfo@Inspect{Maybe Integer
Text
UTCTime
ImageConfig
iiVirtualSize :: Inspect -> Maybe Integer
iiCreated :: Inspect -> UTCTime
iiConfig :: Inspect -> ImageConfig
iiVirtualSize :: Maybe Integer
iiId :: Text
iiCreated :: UTCTime
iiConfig :: ImageConfig
iiId :: Inspect -> Text
..} <- case Maybe Inspect
maybeImageInfo of
       Just Inspect
ii -> Inspect -> RIO env Inspect
forall (m :: * -> *) a. Monad m => a -> m a
return Inspect
ii
       Maybe Inspect
Nothing
         | DockerOpts -> Bool
dockerAutoPull DockerOpts
docker ->
             do DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image
                Maybe Inspect
mii2 <- FilePath -> RIO env (Maybe Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
                case Maybe Inspect
mii2 of
                  Just Inspect
ii2 -> Inspect -> RIO env Inspect
forall (m :: * -> *) a. Monad m => a -> m a
return Inspect
ii2
                  Maybe Inspect
Nothing -> StackDockerException -> RIO env Inspect
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
InspectFailedException FilePath
image)
         | Bool
otherwise -> StackDockerException -> RIO env Inspect
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
NotPulledException FilePath
image)
     Path Abs Dir
projectRoot <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
     Path Abs Dir
sandboxDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
     let ImageConfig {[FilePath]
icEntrypoint :: ImageConfig -> [FilePath]
icEnv :: ImageConfig -> [FilePath]
icEntrypoint :: [FilePath]
icEnv :: [FilePath]
..} = ImageConfig
iiConfig
         imageEnvVars :: [(FilePath, FilePath)]
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
'=')) [FilePath]
icEnv
         platformVariant :: FilePath
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 :: Path Abs Dir
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)
stackRootL Config
config
         sandboxHomeDir :: Path Abs Dir
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
isTerm = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
                  Bool
isStdinTerminal Bool -> Bool -> Bool
&&
                  Bool
isStdoutTerminal Bool -> Bool -> Bool
&&
                  Bool
isStderrTerminal
         keepStdinOpen :: Bool
keepStdinOpen = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
                         -- 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.
                         (Bool
isTerm Bool -> Bool -> Bool
|| (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
bamboo Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
jenkins))
     let mpath :: Maybe Text
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
     Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
mpath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
       Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"The Docker image does not set the PATH env var"
       Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"
     Text
newPathEnv <- (ProcessException -> RIO env Text)
-> (Text -> RIO env Text)
-> Either ProcessException Text
-> RIO env Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Text -> RIO env Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ProcessException Text -> RIO env Text)
-> Either ProcessException Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe Text -> Either ProcessException Text
augmentPath
                      [ FilePath
hostBinDir
                      , Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs Dir
sandboxHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotLocal Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin)]
                      Maybe Text
mpath
     (FilePath
cmnd,[FilePath]
args,[(FilePath, FilePath)]
envVars,[Mount]
extraMount) <- DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker
     Path Abs Dir
pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
     IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir -> IO ()) -> [Path Abs Dir] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir [Path Abs Dir
sandboxHomeDir, Path Abs Dir
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
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
     Bool
sshDirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
sshDir
     Bool
sshSandboxDirExists <-
         IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
             (FilePath -> IO Bool
Files.fileExist
                 (Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir 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)))
     Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sshDirExists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sshSandboxDirExists)
         (IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
             (FilePath -> FilePath -> IO ()
Files.createSymbolicLink
                 (Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sshDir)
                 (Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir 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))))
     let mountSuffix :: FilePath
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 -> Maybe FilePath
dockerMountMode DockerOpts
docker)
     FilePath
containerID <- FilePath -> RIO env FilePath -> RIO env FilePath
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
projectRoot) (RIO env FilePath -> RIO env FilePath)
-> RIO env FilePath -> RIO env FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
trim (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeUtf8 (ByteString -> FilePath) -> RIO env ByteString -> RIO env FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> RIO env ByteString
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess
       ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [[FilePath
"create"
          ,FilePath
"-e",FilePath
inContainerEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=1"
          ,FilePath
"-e",FilePath
stackRootEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot
          ,FilePath
"-e",FilePath
platformVariantEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=dk" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
platformVariant
          ,FilePath
"-e",FilePath
"HOME=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir
          ,FilePath
"-e",FilePath
"PATH=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
newPathEnv
          ,FilePath
"-e",FilePath
"PWD=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
pwd
          ,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-w",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
pwd]
         ,case DockerOpts -> Maybe FilePath
dockerNetwork DockerOpts
docker of
            Maybe FilePath
Nothing -> [FilePath
"--net=host"]
            Just FilePath
name -> [FilePath
"--net=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
         ,case Maybe FilePath
muserEnv of
            Maybe FilePath
Nothing -> []
            Just FilePath
userEnv -> [FilePath
"-e",FilePath
"USER=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
userEnv]
         ,case Maybe FilePath
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 Maybe FilePath
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
         ,[FilePath
"--entrypoint=/usr/bin/env"
             | Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
oldSandboxIdEnvVar [(FilePath, FilePath)]
imageEnvVars) Bool -> Bool -> Bool
&&
               ([FilePath]
icEntrypoint [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"/usr/local/sbin/docker-entrypoint"] Bool -> Bool -> Bool
||
                 [FilePath]
icEntrypoint [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"/root/entrypoint.sh"])]
         ,((FilePath, FilePath) -> [FilePath])
-> [(FilePath, FilePath)] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
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]) [(FilePath, FilePath)]
envVars
         ,(Mount -> [FilePath]) -> [Mount] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix) ([Mount]
extraMount [Mount] -> [Mount] -> [Mount]
forall a. [a] -> [a] -> [a]
++ DockerOpts -> [Mount]
dockerMount DockerOpts
docker)
         ,(FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
nv -> [FilePath
"-e", FilePath
nv]) (DockerOpts -> [FilePath]
dockerEnv DockerOpts
docker)
         ,case DockerOpts -> Maybe FilePath
dockerContainerName DockerOpts
docker of
            Just FilePath
name -> [FilePath
"--name=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
            Maybe FilePath
Nothing -> []
         ,[FilePath
"-t" | Bool
isTerm]
         ,[FilePath
"-i" | Bool
keepStdinOpen]
         ,DockerOpts -> [FilePath]
dockerRunArgs DockerOpts
docker
         ,[FilePath
image]
         ,[FilePath
cmnd]
         ,[FilePath]
args])
-- MSS 2018-08-30 can the CPP below be removed entirely, and instead exec the
-- `docker` process so that it can handle the signals directly?
#ifndef WINDOWS
     RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
     [(CInt, Handler)]
oldHandlers <- [CInt]
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt
sigINT,CInt
sigABRT,CInt
sigHUP,CInt
sigPIPE,CInt
sigTERM,CInt
sigUSR1,CInt
sigUSR2] ((CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)])
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall a b. (a -> b) -> a -> b
$ \CInt
sig -> do
       let sigHandler :: IO ()
sigHandler = RIO env () -> IO ()
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
"--signal=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ CInt -> FilePath
forall a. Show a => a -> FilePath
show CInt
sig,FilePath
containerID]
             Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
sig CInt -> [CInt] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
sigTERM,CInt
sigABRT]) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
               -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it
               Int -> RIO env ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
30000000
               FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
containerID]
       Handler
oldHandler <- IO Handler -> RIO env Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch IO ()
sigHandler) Maybe SignalSet
forall a. Maybe a
Nothing
       (CInt, Handler) -> RIO env (CInt, Handler)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
sig, Handler
oldHandler)
#endif
     let args' :: [FilePath]
args' = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath
"start"]
                        ,[FilePath
"-a" | Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker)]
                        ,[FilePath
"-i" | Bool
keepStdinOpen]
                        ,[FilePath
containerID]]
     Either ExitCodeException ()
e <- RIO env () -> RIO env (Either ExitCodeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (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]
args' ((ProcessConfig () () () -> RIO env ()) -> RIO env ())
-> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ (ProcessConfig () () () -> RIO env ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
         RIO env (Either ExitCodeException ())
-> RIO env () -> RIO env (Either ExitCodeException ())
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally`
         (do Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts -> Bool
dockerPersist DockerOpts
docker Bool -> Bool -> Bool
|| DockerOpts -> Bool
dockerDetach DockerOpts
docker) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                 FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"rm",FilePath
"-f",FilePath
containerID]
                 RIO env () -> (ExitCodeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_::ExitCodeException) -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#ifndef WINDOWS
             [(CInt, Handler)]
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers (((CInt, Handler) -> RIO env Handler) -> RIO env ())
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(CInt
sig,Handler
oldHandler) ->
               IO Handler -> RIO env Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler Maybe SignalSet
forall a. Maybe a
Nothing
#endif
         )
     case Either ExitCodeException ()
e of
       Left ExitCodeException{ExitCode
eceExitCode :: ExitCodeException -> ExitCode
eceExitCode :: 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 :: FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image =
  do Map Text Inspect
results <- [FilePath] -> RIO env (Map Text Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [FilePath
image]
     case Map Text Inspect -> [(Text, Inspect)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Inspect
results of
       [] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Inspect
forall a. Maybe a
Nothing
       [(Text
_,Inspect
i)] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return (Inspect -> Maybe Inspect
forall a. a -> Maybe a
Just Inspect
i)
       [(Text, Inspect)]
_ -> StackDockerException -> RIO env (Maybe Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
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 :: [FilePath] -> RIO env (Map Text Inspect)
inspects [] = Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Inspect
forall k a. Map k a
Map.empty
inspects [FilePath]
images =
  do Either ExitCodeException ByteString
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 (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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 (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_)
     case Either ExitCodeException ByteString
maybeInspectOut of
       Right ByteString
inspectOut ->
         -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8
         case ByteString -> Either FilePath [Inspect]
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode (FilePath -> ByteString
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 -> StackDockerException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
InvalidInspectOutputException FilePath
msg)
           Right [Inspect]
results -> Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(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 -> Text
iiId Inspect
r,Inspect
r)) [Inspect]
results))
       Left ExitCodeException
ece
         |  (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`LBS.isPrefixOf` ExitCodeException -> ByteString
eceStderr ExitCodeException
ece) [ByteString]
missingImagePrefixes -> Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: [ByteString]
missingImagePrefixes = [ByteString
"Error: No such image", ByteString
"Error: No such object:"]

-- | Pull latest version of configured Docker image from registry.
pull :: HasConfig env => RIO env ()
pull :: RIO env ()
pull =
  do Config
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
configL
     let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
     DockerOpts -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
     (SomeException -> RIO env ())
-> (FilePath -> RIO env ())
-> Either SomeException FilePath
-> RIO env ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker) (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)

-- | Pull Docker image from registry.
pullImage :: (HasProcessContext env, HasLogFunc env)
          => DockerOpts -> String -> RIO env ()
pullImage :: DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image =
  do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Pulling image from registry: '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
image Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"'")
     Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DockerOpts -> Bool
dockerRegistryLogin DockerOpts
docker)
          (do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"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 -> Maybe FilePath
dockerRegistryUsername DockerOpts
docker)
                   ,[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 -> Maybe FilePath
dockerRegistryPassword DockerOpts
docker)
                   ,[(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.
     ExitCode
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 ExitCode
ec of
       ExitCode
ExitSuccess -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       ExitFailure Int
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
PullFailedException FilePath
image)

-- | Check docker version (throws exception if incorrect)
checkDockerVersion
    :: (HasProcessContext env, HasLogFunc env)
    => DockerOpts -> RIO env ()
checkDockerVersion :: DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker =
  do Bool
dockerExists <- FilePath -> RIO env Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
FilePath -> m Bool
doesExecutableExist FilePath
"docker"
     Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dockerExists (StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
DockerNotInstalledException)
     ByteString
dockerVersionOut <- [FilePath] -> RIO env ByteString
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath
"--version"]
     case FilePath -> [FilePath]
words (ByteString -> FilePath
decodeUtf8 ByteString
dockerVersionOut) of
       (FilePath
_:FilePath
_:FilePath
v:[FilePath]
_) ->
         case (Version -> Version) -> Maybe Version -> Maybe Version
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 ->
               StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> StackDockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
             | Version
v' Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
forall a. [a]
prohibitedDockerVersions ->
               StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> StackDockerException
DockerVersionProhibitedException [Version]
forall a. [a]
prohibitedDockerVersions Version
v')
             | Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) ->
               StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (VersionRange -> Version -> StackDockerException
BadDockerVersionException (DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) Version
v')
             | Bool
otherwise ->
               () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Maybe Version
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
InvalidVersionOutputException
       [FilePath]
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
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 (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 :: Bool -> RIO env ()
reset Bool
keepHome = do
  Path Abs Dir
projectRoot <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
  Path Abs Dir
dockerSandboxDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
  IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> IO ()
removeDirectoryContents
            Path Abs Dir
dockerSandboxDir
            [Path Rel Dir
homeDirName | Bool
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 :: (HasProcessContext env, HasLogFunc env)
           => Config -> DockerEntrypoint -> RIO env ()
entrypoint :: Config -> DockerEntrypoint -> RIO env ()
entrypoint config :: Config
config@Config{Bool
Int
[FilePath]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe AbstractResolver
Maybe TemplateName
Maybe GHCVariant
Maybe SCM
Platform
VersionRange
Map (Maybe PackageName) Bool
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Text
PantryConfig
Path Abs File
Path Abs Dir
Path Rel Dir
BuildOpts
NixOpts
VersionCheck
DockerOpts
CompilerRepository
PvpBounds
SetupInfo
PlatformVariant
ProjectConfig (Project, Path Abs File)
DumpLogs
ApplyGhcOptions
UserStorage
Runner
EnvSettings -> IO ProcessContext
configStackDeveloperMode :: Config -> Bool
configRecommendUpgrade :: Config -> Bool
configHideSourcePaths :: Config -> Bool
configUserStorage :: Config -> UserStorage
configResolver :: Config -> Maybe AbstractResolver
configStackRoot :: Config -> Path Abs Dir
configPantryConfig :: Config -> PantryConfig
configRunner :: Config -> Runner
configHackageBaseUrl :: Config -> Text
configSaveHackageCreds :: Config -> Bool
configAllowLocals :: Config -> Bool
configProject :: Config -> ProjectConfig (Project, Path Abs File)
configDumpLogs :: Config -> DumpLogs
configAllowDifferentUser :: Config -> Bool
configDefaultTemplate :: Config -> Maybe TemplateName
configAllowNewer :: Config -> Bool
configApplyGhcOptions :: Config -> ApplyGhcOptions
configRebuildGhcOptions :: Config -> Bool
configExplicitSetupDeps :: Config -> Map (Maybe PackageName) Bool
configModifyCodePage :: Config -> Bool
configPvpBounds :: Config -> PvpBounds
configSetupInfoInline :: Config -> SetupInfo
configSetupInfoLocations :: Config -> [FilePath]
configCabalConfigOpts :: Config -> Map CabalConfigKey [Text]
configGhcOptionsByCat :: Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Config -> Map PackageName [Text]
configScmInit :: Config -> Maybe SCM
configTemplateParams :: Config -> Map Text Text
configConcurrentTests :: Config -> Bool
configExtraLibDirs :: Config -> [FilePath]
configExtraIncludeDirs :: Config -> [FilePath]
configOverrideGccPath :: Config -> Maybe (Path Abs File)
configJobs :: Config -> Int
configRequireStackVersion :: Config -> VersionRange
configLocalBin :: Config -> Path Abs Dir
configCompilerRepository :: Config -> CompilerRepository
configCompilerCheck :: Config -> VersionCheck
configSkipMsys :: Config -> Bool
configSkipGHCCheck :: Config -> Bool
configInstallGHC :: Config -> Bool
configSystemGHC :: Config -> Bool
configLatestSnapshot :: Config -> Text
configGHCBuild :: Config -> Maybe CompilerBuild
configGHCVariant :: Config -> Maybe GHCVariant
configPlatformVariant :: Config -> PlatformVariant
configPrefixTimestamps :: Config -> Bool
configHideTHLoading :: Config -> Bool
configLocalPrograms :: Config -> Path Abs Dir
configLocalProgramsBase :: Config -> Path Abs Dir
configProcessContextSettings :: Config -> EnvSettings -> IO ProcessContext
configNix :: Config -> NixOpts
configBuild :: Config -> BuildOpts
configUserConfigPath :: Config -> Path Abs File
configWorkDir :: Config -> Path Rel Dir
configStackDeveloperMode :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configUserStorage :: UserStorage
configResolver :: Maybe AbstractResolver
configStackRoot :: Path Abs Dir
configPantryConfig :: PantryConfig
configRunner :: Runner
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configDumpLogs :: DumpLogs
configAllowDifferentUser :: Bool
configDefaultTemplate :: Maybe TemplateName
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configExplicitSetupDeps :: Map (Maybe PackageName) Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [FilePath]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configExtraLibDirs :: [FilePath]
configExtraIncludeDirs :: [FilePath]
configOverrideGccPath :: Maybe (Path Abs File)
configJobs :: Int
configRequireStackVersion :: VersionRange
configLocalBin :: Path Abs Dir
configCompilerRepository :: CompilerRepository
configCompilerCheck :: VersionCheck
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configSystemGHC :: Bool
configLatestSnapshot :: Text
configGHCBuild :: Maybe CompilerBuild
configGHCVariant :: Maybe GHCVariant
configPlatformVariant :: PlatformVariant
configPlatform :: Platform
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configUserConfigPath :: Path Abs File
configWorkDir :: Path Rel Dir
configPlatform :: Config -> Platform
configDocker :: Config -> DockerOpts
..} DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: DockerEntrypoint -> Maybe DockerUser
..} =
  MVar Bool -> (Bool -> RIO env Bool) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar Bool
entrypointMVar ((Bool -> RIO env Bool) -> RIO env ())
-> (Bool -> RIO env Bool) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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
      ProcessContext
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
processContextL
      Path Abs Dir
homeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
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 (FilePath -> IO (Path Abs Dir)) -> IO FilePath -> IO (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getEnv FilePath
"HOME"
      -- Get the UserEntry for the 'stack' user in the image, if it exists
      Either () UserEntry
estackUserEntry0 <- IO (Either () UserEntry) -> RIO env (Either () UserEntry)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () UserEntry) -> RIO env (Either () UserEntry))
-> IO (Either () UserEntry) -> RIO env (Either () UserEntry)
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe ()) -> IO UserEntry -> IO (Either () UserEntry)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO UserEntry -> IO (Either () UserEntry))
-> IO UserEntry -> IO (Either () UserEntry)
forall a b. (a -> b) -> a -> b
$
        FilePath -> IO UserEntry
User.getUserEntryForName FilePath
stackUserName
      -- Switch UID/GID if needed, and update user's home directory
      case Maybe DockerUser
deUser of
        Maybe DockerUser
Nothing -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just DockerUser
du -> 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 a b loc.
(HasProcessContext env, HasLogFunc env) =>
Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either () UserEntry
estackUserEntry0 Path Abs Dir
homeDir DockerUser
du
      case Either () UserEntry
estackUserEntry0 of
        Left ()
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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
          Path Abs Dir
origStackHomeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
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
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
          Bool
buildPlanDirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
          Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildPlanDirExists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
            ([Path Abs Dir]
_, [Path Abs File]
buildPlans) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
            [Path Abs File] -> (Path Abs File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
buildPlans ((Path Abs File -> RIO env ()) -> RIO env ())
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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)
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
              Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
destBuildPlan
              Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
                Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
destBuildPlan)
                Path Abs File -> Path Abs File -> RIO env ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
srcBuildPlan Path Abs File
destBuildPlan
    Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where
    updateOrCreateStackUser :: Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either a b
estackUserEntry Path loc Dir
homeDir DockerUser{[GroupID]
FileMode
GroupID
UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: DockerUser -> FileMode
duGroups :: DockerUser -> [GroupID]
duGid :: DockerUser -> GroupID
duUid :: DockerUser -> UserID
..} = 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 GroupID
duGid
            ,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 UserID
duUid
            ,FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
duGid
            ,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 UserID
duUid
            ,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 GroupID
duGid
            ,FilePath
stackUserName]
      [GroupID] -> (GroupID -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupID]
duGroups ((GroupID -> RIO env ()) -> RIO env ())
-> (GroupID -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \GroupID
gid -> do
        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 (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 GroupID
duGid
#ifndef WINDOWS
        [GroupID] -> IO ()
PosixUser.setGroups [GroupID]
duGroups
#endif
        UserID -> IO ()
User.setUserID UserID
duUid
        FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    stackUserName :: FilePath
stackUserName = FilePath
"stack"::String

-- | MVar used to ensure the Docker entrypoint is performed exactly once
entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar :: MVar Bool
entrypointMVar = IO (MVar Bool) -> MVar Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
False)

-- | 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 Bool
isRootDir <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
path
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRootDir
          (do ([Path Abs Dir]
lsd,[Path Abs File]
lsf) <- Path Abs Dir -> IO ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
path
              [Path Abs Dir] -> (Path Abs Dir -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
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 (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))
              [Path Abs File] -> (Path Abs File -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
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 (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 '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 :: [FilePath] -> RIO env ByteString
readDockerProcess [FilePath]
args = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> RIO env ByteString -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ByteString)
-> RIO env ByteString
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 ByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
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 :: RIO env (Path Abs Dir)
getProjectRoot = do
  Maybe (Path Abs Dir)
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
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
  RIO env (Path Abs Dir)
-> (Path Abs Dir -> RIO env (Path Abs Dir))
-> Maybe (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StackDockerException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
CannotDetermineProjectRootException) Path Abs Dir -> RIO env (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
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
iiConfig      :: ImageConfig
  ,Inspect -> UTCTime
iiCreated     :: UTCTime
  ,Inspect -> Text
iiId          :: Text
  ,Inspect -> Maybe Integer
iiVirtualSize :: 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
showList :: [Inspect] -> FilePath -> FilePath
$cshowList :: [Inspect] -> FilePath -> FilePath
show :: Inspect -> FilePath
$cshow :: Inspect -> FilePath
showsPrec :: Int -> Inspect -> FilePath -> FilePath
$cshowsPrec :: Int -> Inspect -> FilePath -> FilePath
Show)

-- | Parse @docker inspect@ output.
instance FromJSON Inspect where
  parseJSON :: Value -> Parser Inspect
parseJSON Value
v =
    do Object
o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
       ImageConfig -> UTCTime -> Text -> Maybe Integer -> Inspect
Inspect (ImageConfig -> UTCTime -> Text -> Maybe Integer -> Inspect)
-> Parser ImageConfig
-> Parser (UTCTime -> Text -> Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser ImageConfig
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Config"
               Parser (UTCTime -> Text -> Maybe Integer -> Inspect)
-> Parser UTCTime -> Parser (Text -> Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser UTCTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Created"
               Parser (Text -> Maybe Integer -> Inspect)
-> Parser Text -> Parser (Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Id"
               Parser (Maybe Integer -> Inspect)
-> Parser (Maybe Integer) -> Parser Inspect
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"VirtualSize"

-- | Parsed @Config@ section of @docker inspect@ output.
data ImageConfig = ImageConfig
  {ImageConfig -> [FilePath]
icEnv :: [String]
  ,ImageConfig -> [FilePath]
icEntrypoint :: [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
showList :: [ImageConfig] -> FilePath -> FilePath
$cshowList :: [ImageConfig] -> FilePath -> FilePath
show :: ImageConfig -> FilePath
$cshow :: ImageConfig -> FilePath
showsPrec :: Int -> ImageConfig -> FilePath -> FilePath
$cshowsPrec :: Int -> ImageConfig -> FilePath -> FilePath
Show)

-- | Parse @Config@ section of @docker inspect@ output.
instance FromJSON ImageConfig where
  parseJSON :: Value -> Parser ImageConfig
parseJSON Value
v =
    do Object
o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
       [FilePath] -> [FilePath] -> ImageConfig
ImageConfig
         ([FilePath] -> [FilePath] -> ImageConfig)
-> Parser [FilePath] -> Parser ([FilePath] -> ImageConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Maybe [FilePath]) -> Maybe [FilePath])
-> Parser (Maybe (Maybe [FilePath])) -> Parser (Maybe [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [FilePath]) -> Maybe [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o Object -> Text -> Parser (Maybe (Maybe [FilePath]))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Env") Parser (Maybe [FilePath]) -> [FilePath] -> Parser [FilePath]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
         Parser ([FilePath] -> ImageConfig)
-> Parser [FilePath] -> Parser ImageConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe (Maybe [FilePath]) -> Maybe [FilePath])
-> Parser (Maybe (Maybe [FilePath])) -> Parser (Maybe [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [FilePath]) -> Maybe [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o Object -> Text -> Parser (Maybe (Maybe [FilePath]))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Entrypoint") Parser (Maybe [FilePath]) -> [FilePath] -> Parser [FilePath]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []