{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
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
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
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])
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
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
&&
(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]
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"]
,[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])
#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
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
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 :: (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")
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 <-
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 ->
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 :: 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)
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_)
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)
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)
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
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]
[])
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
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"
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
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
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
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
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]
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
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)
removeDirectoryContents :: Path Abs Dir
-> [Path Rel Dir]
-> [Path Rel File]
-> 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)))
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_
homeDirName :: Path Rel Dir
homeDirName :: Path Rel Dir
homeDirName = Path Rel Dir
relDirUnderHome
hostBinDir :: FilePath
hostBinDir :: FilePath
hostBinDir = FilePath
"/opt/host/bin"
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 :: ByteString -> FilePath
decodeUtf8 ByteString
bs = Text -> FilePath
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
bs)
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
oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar :: FilePath
oldSandboxIdEnvVar = FilePath
"DOCKER_SANDBOX_ID"
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)
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"
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)
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
.!= []