{-# 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
, DockerException (..)
, getProjectRoot
, runContainerAndExit
) where
import qualified Crypto.Hash as Hash ( Digest, MD5, hash )
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char ( isAscii, isDigit )
import Data.Conduit.List ( sinkNull )
import Data.Conduit.Process.Typed hiding ( proc )
import Data.List ( dropWhileEnd, isInfixOf, isPrefixOf )
import Data.List.Extra ( trim )
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time ( UTCTime )
import qualified Data.Version ( parseVersion )
import Distribution.Version ( mkVersion, mkVersion' )
import Pantry.Internal.AesonExtended
( FromJSON (..), (.:), (.:?), (.!=), eitherDecode )
import Path
import Path.Extra ( toFilePathNoTrailingSep )
import Path.IO hiding ( canonicalizePath )
import qualified RIO.Directory
import RIO.Process
import Stack.Config ( getInContainer )
import Stack.Constants
import Stack.Constants.Config
import Stack.Prelude
import Stack.Setup ( ensureDockerStackExe )
import Stack.Storage.User
( loadDockerImageExeCache, saveDockerImageExeCache )
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Version ( showStackVersion, withinRange )
import System.Environment
( getArgs, getEnv, getEnvironment, getExecutablePath
, getProgName
)
import qualified System.FilePath as FP
import System.IO.Error ( isDoesNotExistError )
import System.IO.Unsafe ( unsafePerformIO )
#ifndef WINDOWS
import System.Posix.Signals
import qualified System.Posix.User as PosixUser
#endif
import qualified System.PosixCompat.User as User
import qualified System.PosixCompat.Files as Files
import System.Terminal ( hIsTerminalDeviceOrMinTTY )
import Text.ParserCombinators.ReadP ( readP_to_S )
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 (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just DockerUser{[GroupID]
UserID
FileMode
GroupID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
..})
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[FilePath]
args <-
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
([FilePath
"--" forall a. [a] -> [a] -> [a]
++ FilePath
reExecArgName forall a. [a] -> [a] -> [a]
++ FilePath
"=" forall a. [a] -> [a] -> [a]
++ FilePath
showStackVersion
,FilePath
"--" forall a. [a] -> [a] -> [a]
++ FilePath
dockerEntrypointArgName
,forall a. Show a => a -> FilePath
show DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: Maybe DockerUser
..}] forall a. [a] -> [a] -> [a]
++)
(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getArgs)
case DockerOpts -> Maybe DockerStackExe
dockerStackExe (Config -> DockerOpts
configDocker Config
config) of
Just DockerStackExe
DockerStackExeHost
| Config -> Platform
configPlatform Config
config forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
Path Abs File
exePath <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
| Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
UnsupportedStackExeHostPlatformException
Just DockerStackExe
DockerStackExeImage -> do
FilePath
progName <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getProgName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
Just (DockerStackExePath Path Abs File
path) -> do
forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
path
Just DockerStackExe
DockerStackExeDownload -> forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe DockerStackExe
Nothing
| Config -> Platform
configPlatform Config
config forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
(Path Abs File
exePath,UTCTime
exeTimestamp,Maybe Bool
misCompatible) <-
do Path Abs File
exePath <- forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
UTCTime
exeTimestamp <- forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path Abs File
exePath
Maybe Bool
isKnown <-
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache
(Inspect -> Text
iiId Inspect
imageInfo)
Path Abs File
exePath
UTCTime
exeTimestamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
exePath, UTCTime
exeTimestamp, Maybe Bool
isKnown)
case Maybe Bool
misCompatible of
Just Bool
True -> forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
Just Bool
False -> forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe Bool
Nothing -> do
Either ExitCodeException ((), ())
e <-
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$
forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath
-> [FilePath]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout
FilePath
"docker"
[ FilePath
"run"
, FilePath
"-v"
, forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath forall a. [a] -> [a] -> [a]
++ FilePath
":" forall a. [a] -> [a] -> [a]
++ FilePath
"/tmp/stack"
, Text -> FilePath
T.unpack (Inspect -> Text
iiId Inspect
imageInfo)
, FilePath
"/tmp/stack"
, FilePath
"--version"]
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
let compatible :: Bool
compatible =
case Either ExitCodeException ((), ())
e of
Left ExitCodeException{} -> Bool
False
Right ((), ())
_ -> Bool
True
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
saveDockerImageExeCache
(Inspect -> Text
iiId Inspect
imageInfo)
Path Abs File
exePath
UTCTime
exeTimestamp
Bool
compatible
if Bool
compatible
then forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
else forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe DockerStackExe
Nothing -> forall {env} {b} {a}.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
where
exeDownload :: b -> RIO env (FilePath, b, [a], [Mount])
exeDownload b
args = do
Path Abs File
exePath <- forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
dockerContainerPlatform
forall {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path Abs File
exePath
cmdArgs :: b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path b File
exePath = do
let exeBase :: Path b File
exeBase =
case forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
splitExtension Path b File
exePath of
Left SomeException
_ -> Path b File
exePath
Right (Path b File
x, FilePath
_) -> Path b File
x
let mountPath :: FilePath
mountPath = FilePath
hostBinDir FilePath -> FilePath -> FilePath
FP.</> forall b t. Path b t -> FilePath
toFilePath (forall b. Path b File -> Path Rel File
filename Path b File
exeBase)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
mountPath, b
args, [], [FilePath -> FilePath -> Mount
Mount (forall b t. Path b t -> FilePath
toFilePath Path b File
exePath) FilePath
mountPath])
preventInContainer :: MonadIO m => m () -> m ()
preventInContainer :: forall (m :: * -> *). MonadIO m => m () -> m ()
preventInContainer m ()
inner =
do Bool
inContainer <- forall (m :: * -> *). MonadIO m => m Bool
getInContainer
if Bool
inContainer
then forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
OnlyOnHostException
else m ()
inner
runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit :: forall env void. HasConfig env => RIO env void
runContainerAndExit = do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
([(FilePath, FilePath)]
env,Bool
isStdinTerminal,Bool
isStderrTerminal,Path Abs Dir
homeDir) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
(,,,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stdin
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stderr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
Bool
isStdoutTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
let dockerHost :: Maybe FilePath
dockerHost = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_HOST" [(FilePath, FilePath)]
env
dockerCertPath :: Maybe FilePath
dockerCertPath = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_CERT_PATH" [(FilePath, FilePath)]
env
bamboo :: Maybe FilePath
bamboo = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"bamboo_buildKey" [(FilePath, FilePath)]
env
jenkins :: Maybe FilePath
jenkins = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"JENKINS_HOME" [(FilePath, FilePath)]
env
msshAuthSock :: Maybe FilePath
msshAuthSock = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"SSH_AUTH_SOCK" [(FilePath, FilePath)]
env
muserEnv :: Maybe FilePath
muserEnv = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"USER" [(FilePath, FilePath)]
env
isRemoteDocker :: Bool
isRemoteDocker = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"tcp://") Maybe FilePath
dockerHost
Maybe FilePath
mstackYaml <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"STACK_YAML" [(FilePath, FilePath)]
env) forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
RIO.Directory.makeAbsolute
FilePath
image <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isRemoteDocker Bool -> Bool -> Bool
&&
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
"boot2docker") Maybe FilePath
dockerCertPath)
(forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Warning: Using boot2docker is NOT supported, and not likely to perform well.")
Maybe Inspect
maybeImageInfo <- forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
imageInfo :: Inspect
imageInfo@Inspect{Maybe Integer
UTCTime
Text
ImageConfig
iiVirtualSize :: Inspect -> Maybe Integer
iiCreated :: Inspect -> UTCTime
iiConfig :: Inspect -> ImageConfig
iiVirtualSize :: Maybe Integer
iiId :: Text
iiCreated :: UTCTime
iiConfig :: ImageConfig
iiId :: Inspect -> Text
..} <- case Maybe Inspect
maybeImageInfo of
Just Inspect
ii -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii
Maybe Inspect
Nothing
| DockerOpts -> Bool
dockerAutoPull DockerOpts
docker ->
do forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image
Maybe Inspect
mii2 <- forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
case Maybe Inspect
mii2 of
Just Inspect
ii2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii2
Maybe Inspect
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
InspectFailedException FilePath
image)
| Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
NotPulledException FilePath
image)
Path Abs Dir
projectRoot <- forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
Path Abs Dir
sandboxDir <- forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
let ImageConfig {[FilePath]
icEntrypoint :: ImageConfig -> [FilePath]
icEnv :: ImageConfig -> [FilePath]
icEntrypoint :: [FilePath]
icEnv :: [FilePath]
..} = ImageConfig
iiConfig
imageEnvVars :: [(FilePath, FilePath)]
imageEnvVars = forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'=')) [FilePath]
icEnv
platformVariant :: FilePath
platformVariant = forall a. Show a => a -> FilePath
show forall a b. (a -> b) -> a -> b
$ FilePath -> Digest MD5
hashRepoName FilePath
image
stackRoot :: Path Abs Dir
stackRoot = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config
sandboxHomeDir :: Path Abs Dir
sandboxHomeDir = Path Abs Dir
sandboxDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
homeDirName
isTerm :: Bool
isTerm = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
Bool
isStdinTerminal Bool -> Bool -> Bool
&&
Bool
isStdoutTerminal Bool -> Bool -> Bool
&&
Bool
isStderrTerminal
keepStdinOpen :: Bool
keepStdinOpen = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
(Bool
isTerm Bool -> Bool -> Bool
|| (forall a. Maybe a -> Bool
isNothing Maybe FilePath
bamboo Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe FilePath
jenkins))
let mpath :: Maybe Text
mpath = FilePath -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
"PATH" [(FilePath, FilePath)]
imageEnvVars
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Text
mpath) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"The Docker image does not set the PATH env var"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"
Text
newPathEnv <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe Text -> Either ProcessException Text
augmentPath
[ FilePath
hostBinDir
, forall b t. Path b t -> FilePath
toFilePath (Path Abs Dir
sandboxHomeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotLocal forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin)]
Maybe Text
mpath
(FilePath
cmnd,[FilePath]
args,[(FilePath, FilePath)]
envVars,[Mount]
extraMount) <- forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker
Path Abs Dir
pwd <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir [Path Abs Dir
sandboxHomeDir, Path Abs Dir
stackRoot]
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 (f :: * -> *) a. Applicative f => a -> f a
pure (CInt
sig, Handler
oldHandler)
#endif
let args' :: [FilePath]
args' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath
"start"]
,[FilePath
"-a" | Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker)]
,[FilePath
"-i" | Bool
keepStdinOpen]
,[FilePath
containerID]]
Either ExitCodeException ()
e <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath]
args' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally`
(do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts -> Bool
dockerPersist DockerOpts
docker Bool -> Bool -> Bool
|| DockerOpts -> Bool
dockerDetach DockerOpts
docker) forall a b. (a -> b) -> a -> b
$
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"rm",FilePath
"-f",FilePath
containerID]
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_::ExitCodeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
#ifndef WINDOWS
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers forall a b. (a -> b) -> a -> b
$ \(CInt
sig,Handler
oldHandler) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler forall a. Maybe a
Nothing
#endif
)
case Either ExitCodeException ()
e of
Left ExitCodeException{ExitCode
eceExitCode :: ExitCodeException -> ExitCode
eceExitCode :: ExitCode
eceExitCode} -> forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith ExitCode
eceExitCode
Right () -> forall (m :: * -> *) a. MonadIO m => m a
exitSuccess
where
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 (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[(Text
_,Inspect
i)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Inspect
i)
[(Text, Inspect)]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
InvalidInspectOutputException FilePath
"expect a single result")
inspects :: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env (Map Text Inspect)
inspects :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
inspects [FilePath]
images =
do Either ExitCodeException ByteString
maybeInspectOut <-
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 -> DockerException
InvalidInspectOutputException FilePath
msg)
Right [Inspect]
results -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\Inspect
r -> (Inspect -> Text
iiId Inspect
r,Inspect
r)) [Inspect]
results))
Left ExitCodeException
ece
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`LBS.isPrefixOf` ExitCodeException -> ByteString
eceStderr ExitCodeException
ece) [ByteString]
missingImagePrefixes -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
Left ExitCodeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCodeException
e
where missingImagePrefixes :: [ByteString]
missingImagePrefixes = [ByteString
"Error: No such image", ByteString
"Error: No such object:"]
pull :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
ExitFailure Int
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
PullFailedException FilePath
image)
checkDockerVersion ::
(HasProcessContext env, HasLogFunc env)
=> DockerOpts -> RIO env ()
checkDockerVersion :: forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker =
do Bool
dockerExists <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
FilePath -> m Bool
doesExecutableExist FilePath
"docker"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dockerExists (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
DockerNotInstalledException)
ByteString
dockerVersionOut <- forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath
"--version"]
case FilePath -> [FilePath]
words (ByteString -> FilePath
decodeUtf8 ByteString
dockerVersionOut) of
(FilePath
_:FilePath
_:FilePath
v:[FilePath]
_) ->
case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> Version
mkVersion' forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Version
parseVersion' forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
stripVersion FilePath
v of
Just Version
v'
| Version
v' forall a. Ord a => a -> a -> Bool
< Version
minimumDockerVersion ->
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> DockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
| Version
v' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. [a]
prohibitedDockerVersions ->
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> DockerException
DockerVersionProhibitedException forall a. [a]
prohibitedDockerVersions Version
v')
| Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) ->
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (VersionRange -> Version -> DockerException
BadDockerVersionException (DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) Version
v')
| Bool
otherwise ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe Version
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
[FilePath]
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
where minimumDockerVersion :: Version
minimumDockerVersion = [Int] -> Version
mkVersion [Int
1, Int
6, Int
0]
prohibitedDockerVersions :: [a]
prohibitedDockerVersions = []
stripVersion :: FilePath -> FilePath
stripVersion FilePath
v = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') (forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) FilePath
v)
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just DockerUser
du -> forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
envOverride forall a b. (a -> b) -> a -> b
$ forall {env} {a} {b} {loc}.
(HasProcessContext env, HasLogFunc env) =>
Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either () UserEntry
estackUserEntry0 Path Abs Dir
homeDir DockerUser
du
case Either () UserEntry
estackUserEntry0 of
Left ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right UserEntry
ue -> do
Path Abs Dir
origStackHomeDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (UserEntry -> FilePath
User.homeDirectory UserEntry
ue)
let origStackRoot :: Path Abs Dir
origStackRoot = Path Abs Dir
origStackHomeDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotStackProgName
Bool
buildPlanDirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildPlanDirExists forall a b. (a -> b) -> a -> b
$ do
([Path Abs Dir]
_, [Path Abs File]
buildPlans) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
buildPlans forall a b. (a -> b) -> a -> b
$ \Path Abs File
srcBuildPlan -> do
let destBuildPlan :: Path Abs File
destBuildPlan = Path Abs Dir -> Path Abs Dir
buildPlanDir (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config) forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Abs File
srcBuildPlan
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
destBuildPlan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
destBuildPlan)
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
srcBuildPlan Path Abs File
destBuildPlan
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
where
updateOrCreateStackUser :: Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either a b
estackUserEntry Path loc Dir
homeDir DockerUser{[GroupID]
UserID
FileMode
GroupID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: DockerUser -> FileMode
duGroups :: DockerUser -> [GroupID]
duGid :: DockerUser -> GroupID
duUid :: DockerUser -> UserID
..} = do
case Either a b
estackUserEntry of
Left a
_ -> do
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
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 DockerException
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
.!= []