{-# 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
  ,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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just DockerUser{[GroupID]
GroupID
FileMode
UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
..})
            else forall (m :: * -> *) a. Monad m => a -> m a
return 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]
++ Version -> FilePath
Data.Version.showVersion Version
Meta.version
             ,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 {m :: * -> *} {b} {b} {a}.
Monad m =>
b -> Path b File -> m (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 StackDockerException
UnsupportedStackExeHostPlatformException
        Just DockerStackExe
DockerStackExeImage -> do
            FilePath
progName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getProgName
            forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
        Just (DockerStackExePath Path Abs File
path) -> do
            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 -> 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 (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 -> 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 -> 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 {m :: * -> *} {b} {b} {a}.
Monad m =>
b -> Path b File -> m (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 {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

        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 (m :: * -> *) a. Monad m => a -> m a
return (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 StackDockerException
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
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return Inspect
ii2
                  Maybe Inspect
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
InspectFailedException FilePath
image)
         | Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return ())
#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 (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
       [(Text
_,Inspect
i)] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Inspect
i)
       [(Text, 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 :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [] = forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> StackDockerException
InvalidInspectOutputException FilePath
msg)
           Right [Inspect]
results -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return ()
       ExitFailure Int
_ -> 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 :: 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 StackDockerException
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 -> StackDockerException
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 -> StackDockerException
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 -> StackDockerException
BadDockerVersionException (DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) Version
v')
             | Bool
otherwise ->
               forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Maybe Version
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
InvalidVersionOutputException
       [FilePath]
_ -> 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 = 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 (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        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 (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 <- 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 (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]
GroupID
FileMode
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

          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 (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 = 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 StackDockerException
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
.!= []