{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE CPP                 #-}
{-# 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
  , DockerException (..)
  , getProjectRoot
  , runContainerAndExit
  ) where

import qualified Crypto.Hash as Hash ( Digest, MD5, hash )
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, isInfixOf, isPrefixOf )
import           Data.List.Extra ( trim )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Time ( UTCTime )
import qualified Data.Version ( parseVersion )
import           Distribution.Version ( mkVersion, mkVersion' )
import           Pantry.Internal.AesonExtended
                   ( FromJSON (..), (.:), (.:?), (.!=), eitherDecode )
import           Path
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO hiding ( canonicalizePath )
import qualified RIO.Directory
import           RIO.Process
import           Stack.Config ( getInContainer )
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Prelude
import           Stack.Setup ( ensureDockerStackExe )
import           Stack.Storage.User
                   ( loadDockerImageExeCache, saveDockerImageExeCache )
import           Stack.Types.Config
import           Stack.Types.Docker
import           Stack.Types.Version ( showStackVersion, withinRange )
import           System.Environment
                   ( getArgs, getEnv, getEnvironment, getExecutablePath
                   , getProgName
                   )
import qualified System.FilePath as FP
import           System.IO.Error ( isDoesNotExistError )
import           System.IO.Unsafe ( unsafePerformIO )
#ifndef WINDOWS
import           System.Posix.Signals
import qualified System.Posix.User as PosixUser
#endif
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 )

-- | Function to get command and arguments to run in Docker container

getCmdArgs ::
     HasConfig env
  => DockerOpts
  -> Inspect
  -> Bool
  -> RIO env (FilePath,[String],[(String,String)],[Mount])
getCmdArgs :: forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    Maybe DockerUser
deUser <-
        if forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not Bool
isRemoteDocker) (DockerOpts -> Maybe Bool
dockerSetUser DockerOpts
docker)
            then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
              UserID
duUid <- IO UserID
User.getEffectiveUserID
              GroupID
duGid <- IO GroupID
User.getEffectiveGroupID
              [GroupID]
duGroups <- forall a. Ord a => [a] -> [a]
nubOrd 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
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just DockerUser{[GroupID]
UserID
FileMode
GroupID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
..})
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    [FilePath]
args <-
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ([FilePath
"--" forall a. [a] -> [a] -> [a]
++ FilePath
reExecArgName forall a. [a] -> [a] -> [a]
++ FilePath
"=" forall a. [a] -> [a] -> [a]
++ FilePath
showStackVersion
             ,FilePath
"--" forall a. [a] -> [a] -> [a]
++ FilePath
dockerEntrypointArgName
             ,forall a. Show a => a -> FilePath
show DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: Maybe DockerUser
..}] forall a. [a] -> [a] -> [a]
++)
            (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 forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              Path Abs File
exePath <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
              forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
          | Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
UnsupportedStackExeHostPlatformException
        Just DockerStackExe
DockerStackExeImage -> do
            FilePath
progName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getProgName
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
        Just (DockerStackExePath Path Abs File
path) -> do
            forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
path
        Just DockerStackExe
DockerStackExeDownload -> forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
        Maybe DockerStackExe
Nothing
          | Config -> Platform
configPlatform Config
config forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
              (Path Abs File
exePath,UTCTime
exeTimestamp,Maybe Bool
misCompatible) <-
                  do Path Abs File
exePath <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
                     UTCTime
exeTimestamp <- forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path Abs File
exePath
                     Maybe Bool
isKnown <-
                         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
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
exePath, UTCTime
exeTimestamp, Maybe Bool
isKnown)
              case Maybe Bool
misCompatible of
                  Just Bool
True -> forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
                  Just Bool
False -> forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
                  Maybe Bool
Nothing -> do
                      Either ExitCodeException ((), ())
e <-
                          forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$
                          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"
                              , forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ FilePath
"/tmp/stack"
                              , Text -> FilePath
T.unpack (Inspect -> Text
iiId Inspect
imageInfo)
                              , FilePath
"/tmp/stack"
                              , FilePath
"--version"]
                              forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
                              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
                      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 forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
                          else forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
        Maybe DockerStackExe
Nothing -> 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 <- forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
dockerContainerPlatform
        forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path Abs File
exePath
    cmdArgs :: b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path b File
exePath = do
        -- MSS 2020-04-21 previously used replaceExtension, but semantics changed in path 0.7

        -- In any event, I'm not even sure _why_ we need to drop a file extension here

        -- Originally introduced here: https://github.com/commercialhaskell/stack/commit/6218dadaf5fd7bf312bb1bd0db63b4784ba78cb2

        let exeBase :: Path b File
exeBase =
              case forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
splitExtension Path b File
exePath of
                Left SomeException
_ -> Path b File
exePath
                Right (Path b File
x, FilePath
_) -> Path b File
x
        let mountPath :: FilePath
mountPath = FilePath
hostBinDir FilePath -> FilePath -> FilePath
FP.</> forall b t. Path b t -> FilePath
toFilePath (forall b. Path b File -> Path Rel File
filename Path b File
exeBase)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
mountPath, b
args, [], [FilePath -> FilePath -> Mount
Mount (forall b t. Path b t -> FilePath
toFilePath Path b File
exePath) FilePath
mountPath])

-- | Error if running in a container.

preventInContainer :: MonadIO m => m () -> m ()
preventInContainer :: forall (m :: * -> *). MonadIO m => m () -> m ()
preventInContainer m ()
inner =
  do Bool
inContainer <- forall (m :: * -> *). MonadIO m => m Bool
getInContainer
     if Bool
inContainer
        then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
OnlyOnHostException
        else m ()
inner

-- | Run a command in a new Docker container, then exit the process.

runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit :: forall env void. HasConfig env => RIO env void
runContainerAndExit = do
     Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
     let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
     forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
     ([(FilePath, FilePath)]
env,Bool
isStdinTerminal,Bool
isStderrTerminal,Path Abs Dir
homeDir) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
       (,,,)
       forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stdin
       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stderr
       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
     Bool
isStdoutTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
     let dockerHost :: Maybe FilePath
dockerHost = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_HOST" [(FilePath, FilePath)]
env
         dockerCertPath :: Maybe FilePath
dockerCertPath = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_CERT_PATH" [(FilePath, FilePath)]
env
         bamboo :: Maybe FilePath
bamboo = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"bamboo_buildKey" [(FilePath, FilePath)]
env
         jenkins :: Maybe FilePath
jenkins = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"JENKINS_HOME" [(FilePath, FilePath)]
env
         msshAuthSock :: Maybe FilePath
msshAuthSock = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"SSH_AUTH_SOCK" [(FilePath, FilePath)]
env
         muserEnv :: Maybe FilePath
muserEnv = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"USER" [(FilePath, FilePath)]
env
         isRemoteDocker :: Bool
isRemoteDocker = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"tcp://") Maybe FilePath
dockerHost
     Maybe FilePath
mstackYaml <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"STACK_YAML" [(FilePath, FilePath)]
env) forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
RIO.Directory.makeAbsolute
     FilePath
image <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isRemoteDocker Bool -> Bool -> Bool
&&
           forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
"boot2docker") Maybe FilePath
dockerCertPath)
          (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 <- forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
     imageInfo :: Inspect
imageInfo@Inspect{Maybe Integer
UTCTime
Text
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii
       Maybe Inspect
Nothing
         | DockerOpts -> Bool
dockerAutoPull DockerOpts
docker ->
             do forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image
                Maybe Inspect
mii2 <- forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
                case Maybe Inspect
mii2 of
                  Just Inspect
ii2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii2
                  Maybe Inspect
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
InspectFailedException FilePath
image)
         | Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
NotPulledException FilePath
image)
     Path Abs Dir
projectRoot <- forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
     Path Abs Dir
sandboxDir <- 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=')) [FilePath]
icEnv
         platformVariant :: FilePath
platformVariant = forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ FilePath -> Digest MD5
hashRepoName FilePath
image
         stackRoot :: Path Abs Dir
stackRoot = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config
         sandboxHomeDir :: Path Abs Dir
sandboxHomeDir = Path Abs Dir
sandboxDir 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
|| (forall a. Maybe a -> Bool
isNothing Maybe FilePath
bamboo Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe FilePath
jenkins))
     let mpath :: Maybe Text
mpath = FilePath -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
"PATH" [(FilePath, FilePath)]
imageEnvVars
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Text
mpath) forall a b. (a -> b) -> a -> b
$ do
       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"
       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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe Text -> Either ProcessException Text
augmentPath
                      [ FilePath
hostBinDir
                      , forall b t. Path b t -> FilePath
toFilePath (Path Abs Dir
sandboxHomeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotLocal 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) <- 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 <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
     forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ 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 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir
     Bool
sshDirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
sshDir
     Bool
sshSandboxDirExists <-
         forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
             (FilePath -> IO Bool
Files.fileExist
                 (forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir)))
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sshDirExists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sshSandboxDirExists)
         (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
             (FilePath -> FilePath -> IO ()
Files.createSymbolicLink
                 (forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sshDir)
                 (forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir))))
     let mountSuffix :: FilePath
mountSuffix = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
":" forall a. [a] -> [a] -> [a]
++) (DockerOpts -> Maybe FilePath
dockerMountMode DockerOpts
docker)
     FilePath
containerID <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
projectRoot) forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
trim forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess
       (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
         [[FilePath
"create"
          ,FilePath
"-e",FilePath
inContainerEnvVar forall a. [a] -> [a] -> [a]
++ FilePath
"=1"
          ,FilePath
"-e",FilePath
stackRootEnvVar forall a. [a] -> [a] -> [a]
++ FilePath
"=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot
          ,FilePath
"-e",FilePath
platformVariantEnvVar forall a. [a] -> [a] -> [a]
++ FilePath
"=dk" forall a. [a] -> [a] -> [a]
++ FilePath
platformVariant
          ,FilePath
"-e",FilePath
"HOME=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir
          ,FilePath
"-e",FilePath
"PATH=" forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
newPathEnv
          ,FilePath
"-e",FilePath
"PWD=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
pwd
          ,FilePath
"-v",forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-v",forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
          ,FilePath
"-w",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=" forall a. [a] -> [a] -> [a]
++ FilePath
name]
         ,case Maybe FilePath
muserEnv of
            Maybe FilePath
Nothing -> []
            Just FilePath
userEnv -> [FilePath
"-e",FilePath
"USER=" forall a. [a] -> [a] -> [a]
++ FilePath
userEnv]
         ,case Maybe FilePath
msshAuthSock of
            Maybe FilePath
Nothing -> []
            Just FilePath
sshAuthSock ->
              [FilePath
"-e",FilePath
"SSH_AUTH_SOCK=" forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock
              ,FilePath
"-v",FilePath
sshAuthSock forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock]
         ,case Maybe FilePath
mstackYaml of
            Maybe FilePath
Nothing -> []
            Just FilePath
stackYaml ->
              [FilePath
"-e",FilePath
"STACK_YAML=" forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml
              ,FilePath
"-v",FilePath
stackYamlforall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml forall a. [a] -> [a] -> [a]
++ FilePath
":ro"]
           -- Disable the deprecated entrypoint in FP Complete-generated images

         ,[FilePath
"--entrypoint=/usr/bin/env"
             | forall a. Maybe a -> Bool
isJust (forall {a}. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
oldSandboxIdEnvVar [(FilePath, FilePath)]
imageEnvVars) Bool -> Bool -> Bool
&&
               ([FilePath]
icEntrypoint forall a. Eq a => a -> a -> Bool
== [FilePath
"/usr/local/sbin/docker-entrypoint"] Bool -> Bool -> Bool
||
                 [FilePath]
icEntrypoint forall a. Eq a => a -> a -> Bool
== [FilePath
"/root/entrypoint.sh"])]
         ,forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(FilePath
k,FilePath
v) -> [FilePath
"-e", FilePath
k forall a. [a] -> [a] -> [a]
++ FilePath
"=" forall a. [a] -> [a] -> [a]
++ FilePath
v]) [(FilePath, FilePath)]
envVars
         ,forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix) ([Mount]
extraMount forall a. [a] -> [a] -> [a]
++ DockerOpts -> [Mount]
dockerMount DockerOpts
docker)
         ,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=" 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 <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
     [(CInt, Handler)]
oldHandlers <- 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] forall a b. (a -> b) -> a -> b
$ \CInt
sig -> do
       let sigHandler :: IO ()
sigHandler = RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$ do
             forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
"--signal=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show CInt
sig,FilePath
containerID]
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
sig forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
sigTERM,CInt
sigABRT]) forall a b. (a -> b) -> a -> b
$ do
               -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it

               forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
30000000
               forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
containerID]
       Handler
oldHandler <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch IO ()
sigHandler) forall a. Maybe a
Nothing
       forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt
sig, Handler
oldHandler)
#endif
     let args' :: [FilePath]
args' = 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 <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (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' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
         forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally`
         (do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts -> Bool
dockerPersist DockerOpts
docker Bool -> Bool -> Bool
|| DockerOpts -> Bool
dockerDetach DockerOpts
docker) forall a b. (a -> b) -> a -> b
$
                 forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"rm",FilePath
"-f",FilePath
containerID]
                 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_::ExitCodeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
#ifndef WINDOWS
             forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers forall a b. (a -> b) -> a -> b
$ \(CInt
sig,Handler
oldHandler) ->
               forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler forall a. Maybe a
Nothing
#endif
         )
     case Either ExitCodeException ()
e of
       Left ExitCodeException{ExitCode
eceExitCode :: ExitCodeException -> ExitCode
eceExitCode :: ExitCode
eceExitCode} -> forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith ExitCode
eceExitCode
       Right () -> 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 = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'@')
    lookupImageEnv :: a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv a
name [(a, FilePath)]
vars =
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, FilePath)]
vars of
        Just (Char
'=':FilePath
val) -> forall a. a -> Maybe a
Just FilePath
val
        Maybe FilePath
_ -> forall a. Maybe a
Nothing
    mountArg :: FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix (Mount FilePath
host FilePath
container) =
      [FilePath
"-v",FilePath
host forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ FilePath
container forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix]
    sshRelDir :: Path Rel Dir
sshRelDir = Path Rel Dir
relDirDotSsh

-- | Inspect Docker image or container.

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

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

inspects :: (HasProcessContext env, HasLogFunc env)
         => [String] -> RIO env (Map Text Inspect)
inspects :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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.

       forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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" forall a. a -> [a] -> [a]
: [FilePath]
images) 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 forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode (FilePath -> ByteString
LBS.pack (forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAscii (ByteString -> FilePath
decodeUtf8 ByteString
inspectOut))) of
           Left FilePath
msg -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
InvalidInspectOutputException FilePath
msg)
           Right [Inspect]
results -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\Inspect
r -> (Inspect -> Text
iiId Inspect
r,Inspect
r)) [Inspect]
results))
       Left ExitCodeException
ece
         |  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`LBS.isPrefixOf` ExitCodeException -> ByteString
eceStderr ExitCodeException
ece) [ByteString]
missingImagePrefixes -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
       Left ExitCodeException
e -> 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 :: forall env. HasConfig env => RIO env ()
pull =
  do Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
     let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
     forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
     forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image =
  do forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Pulling image from registry: '" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
image forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"'")
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DockerOpts -> Bool
dockerRegistryLogin DockerOpts
docker)
          (do forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"You may need to log in."
              forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc
                FilePath
"docker"
                (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                   [[FilePath
"login"]
                   ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
n -> [FilePath
"--username=" forall a. [a] -> [a] -> [a]
++ FilePath
n]) (DockerOpts -> Maybe FilePath
dockerRegistryUsername DockerOpts
docker)
                   ,forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
p -> [FilePath
"--password=" forall a. [a] -> [a] -> [a]
++ FilePath
p]) (DockerOpts -> Maybe FilePath
dockerRegistryPassword DockerOpts
docker)
                   ,[forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'/') FilePath
image]])
                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 <- 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] forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
       let pc :: ProcessConfig () () ()
pc = forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
              forall a b. (a -> b) -> a -> b
$ forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
              forall a b. (a -> b) -> a -> b
$ forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed
                ProcessConfig () () ()
pc0
       forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
pc
     case ExitCode
ec of
       ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       ExitFailure Int
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
PullFailedException FilePath
image)

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

checkDockerVersion ::
       (HasProcessContext env, HasLogFunc env)
    => DockerOpts -> RIO env ()
checkDockerVersion :: forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker =
  do Bool
dockerExists <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
FilePath -> m Bool
doesExecutableExist FilePath
"docker"
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dockerExists (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
DockerNotInstalledException)
     ByteString
dockerVersionOut <- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> Version
mkVersion' forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Version
parseVersion' forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
stripVersion FilePath
v of
           Just Version
v'
             | Version
v' forall a. Ord a => a -> a -> Bool
< Version
minimumDockerVersion ->
               forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> DockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
             | Version
v' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. [a]
prohibitedDockerVersions ->
               forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> DockerException
DockerVersionProhibitedException forall a. [a]
prohibitedDockerVersions Version
v')
             | Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) ->
               forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (VersionRange -> Version -> DockerException
BadDockerVersionException (DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) Version
v')
             | Bool
otherwise ->
               forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           Maybe Version
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
       [FilePath]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
  where minimumDockerVersion :: Version
minimumDockerVersion = [Int] -> Version
mkVersion [Int
1, Int
6, Int
0]
        prohibitedDockerVersions :: [a]
prohibitedDockerVersions = []
        stripVersion :: FilePath -> FilePath
stripVersion FilePath
v = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool -> Bool
not 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' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
Data.Version.parseVersion

-- | Remove the project's Docker sandbox.

reset :: HasConfig env => Bool -> RIO env ()
reset :: forall env. HasConfig env => Bool -> RIO env ()
reset Bool
keepHome = do
  Path Abs Dir
projectRoot <- forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
  Path Abs Dir
dockerSandboxDir <- forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
  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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
Config -> DockerEntrypoint -> RIO env ()
entrypoint config :: Config
config@Config{} DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: DockerEntrypoint -> Maybe DockerUser
..} =
  forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar Bool
entrypointMVar forall a b. (a -> b) -> a -> b
$ \Bool
alreadyRan -> do
    -- Only run the entrypoint once

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyRan forall a b. (a -> b) -> a -> b
$ do
      ProcessContext
envOverride <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
      Path Abs Dir
homeDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just DockerUser
du -> forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
envOverride forall a b. (a -> b) -> a -> b
$ 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 ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right UserEntry
ue -> do
          -- If the 'stack' user exists in the image, copy any build plans and package indices from

          -- its original home directory to the host's Stack root, to avoid needing to download them

          Path Abs Dir
origStackHomeDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotStackProgName
          Bool
buildPlanDirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildPlanDirExists forall a b. (a -> b) -> a -> b
$ do
            ([Path Abs Dir]
_, [Path Abs File]
buildPlans) <- 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)
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
buildPlans 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 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config) forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Abs File
srcBuildPlan
              Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
destBuildPlan
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
destBuildPlan)
                forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
srcBuildPlan Path Abs File
destBuildPlan
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  where
    updateOrCreateStackUser :: Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either a b
estackUserEntry Path loc Dir
homeDir DockerUser{[GroupID]
UserID
FileMode
GroupID
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

          forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupadd"
            [FilePath
"-o"
            ,FilePath
"--gid",forall a. Show a => a -> FilePath
show GroupID
duGid
            ,FilePath
stackUserName]
          forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"useradd"
            [FilePath
"-oN"
            ,FilePath
"--uid",forall a. Show a => a -> FilePath
show UserID
duUid
            ,FilePath
"--gid",forall a. Show a => a -> FilePath
show GroupID
duGid
            ,FilePath
"--home",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

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

      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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 = forall a. IO a -> a
unsafePerformIO (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 <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
path
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRootDir
          (do ([Path Abs Dir]
lsd,[Path Abs File]
lsf) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
path
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
lsd
                    (\Path Abs Dir
d -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
d forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel Dir]
excludeDirs)
                                  (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
d))
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
lsf
                    (\Path Abs File
f -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b. Path b File -> Path Rel File
filename Path Abs File
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel File]
excludeFiles)
                                  (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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath]
args = ByteString -> ByteString
BL.toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 :: forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot = do
  Maybe (Path Abs Dir)
mroot <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe (Path Abs Dir)
configProjectRoot
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
CannotDetermineProjectRootException) 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
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 <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
       ImageConfig -> UTCTime -> Text -> Maybe Integer -> Inspect
Inspect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Config"
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Created"
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Id"
               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o 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
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 <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
       [FilePath] -> [FilePath] -> ImageConfig
ImageConfig
         forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Env") forall a. Parser (Maybe a) -> a -> Parser a
.!= []
         forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Entrypoint") forall a. Parser (Maybe a) -> a -> Parser a
.!= []