{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# 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 :: DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker = do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
Maybe DockerUser
deUser <-
if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not Bool
isRemoteDocker) (DockerOpts -> Maybe Bool
dockerSetUser DockerOpts
docker)
then IO (Maybe DockerUser) -> RIO env (Maybe DockerUser)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe DockerUser) -> RIO env (Maybe DockerUser))
-> IO (Maybe DockerUser) -> RIO env (Maybe DockerUser)
forall a b. (a -> b) -> a -> b
$ do
UserID
duUid <- IO UserID
User.getEffectiveUserID
GroupID
duGid <- IO GroupID
User.getEffectiveGroupID
[GroupID]
duGroups <- [GroupID] -> [GroupID]
forall a. Ord a => [a] -> [a]
nubOrd ([GroupID] -> [GroupID]) -> IO [GroupID] -> IO [GroupID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [GroupID]
User.getGroups
FileMode
duUmask <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
0o022
FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
Maybe DockerUser -> IO (Maybe DockerUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (DockerUser -> Maybe DockerUser
forall a. a -> Maybe a
Just DockerUser :: UserID -> GroupID -> [GroupID] -> FileMode -> DockerUser
DockerUser{[GroupID]
FileMode
GroupID
UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
..})
else Maybe DockerUser -> RIO env (Maybe DockerUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DockerUser
forall a. Maybe a
Nothing
[FilePath]
args <-
([FilePath] -> [FilePath])
-> RIO env [FilePath] -> RIO env [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
([FilePath
"--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
reExecArgName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
Data.Version.showVersion Version
Meta.version
,FilePath
"--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dockerEntrypointArgName
,DockerEntrypoint -> FilePath
forall a. Show a => a -> FilePath
show DockerEntrypoint :: Maybe DockerUser -> DockerEntrypoint
DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: Maybe DockerUser
..}] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++)
(IO [FilePath] -> RIO env [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [FilePath]
getArgs)
case DockerOpts -> Maybe DockerStackExe
dockerStackExe (Config -> DockerOpts
configDocker Config
config) of
Just DockerStackExe
DockerStackExeHost
| Config -> Platform
configPlatform Config
config Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
Path Abs File
exePath <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' (FilePath -> RIO env (Path Abs File))
-> RIO env FilePath -> RIO env (Path Abs File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
[FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
| Bool
otherwise -> StackDockerException
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
UnsupportedStackExeHostPlatformException
Just DockerStackExe
DockerStackExeImage -> do
FilePath
progName <- IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getProgName
(FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
Just (DockerStackExePath Path Abs File
path) -> do
[FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
path
Just DockerStackExe
DockerStackExeDownload -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env b a.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe DockerStackExe
Nothing
| Config -> Platform
configPlatform Config
config Platform -> Platform -> Bool
forall a. Eq a => a -> a -> Bool
== Platform
dockerContainerPlatform -> do
(Path Abs File
exePath,UTCTime
exeTimestamp,Maybe Bool
misCompatible) <-
do Path Abs File
exePath <- FilePath -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => FilePath -> m (Path Abs File)
resolveFile' (FilePath -> RIO env (Path Abs File))
-> RIO env FilePath -> RIO env (Path Abs File)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> RIO env FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
UTCTime
exeTimestamp <- Path Abs File -> RIO env UTCTime
forall (m :: * -> *) b t. MonadIO m => Path b t -> m UTCTime
getModificationTime Path Abs File
exePath
Maybe Bool
isKnown <-
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> RIO env (Maybe Bool)
loadDockerImageExeCache
(Inspect -> Text
iiId Inspect
imageInfo)
Path Abs File
exePath
UTCTime
exeTimestamp
(Path Abs File, UTCTime, Maybe Bool)
-> RIO env (Path Abs File, UTCTime, Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs File
exePath, UTCTime
exeTimestamp, Maybe Bool
isKnown)
case Maybe Bool
misCompatible of
Just Bool
True -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
Just Bool
False -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env b a.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe Bool
Nothing -> do
Either ExitCodeException ((), ())
e <-
RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ()))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ())))
-> RIO env ((), ()) -> RIO env (Either ExitCodeException ((), ()))
forall a b. (a -> b) -> a -> b
$
FilePath
-> [FilePath]
-> ConduitM ByteString Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
-> RIO env ((), ())
forall e o env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath
-> [FilePath]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout
FilePath
"docker"
[ FilePath
"run"
, FilePath
"-v"
, Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs File
exePath FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/tmp/stack"
, Text -> FilePath
T.unpack (Inspect -> Text
iiId Inspect
imageInfo)
, FilePath
"/tmp/stack"
, FilePath
"--version"]
ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
sinkNull
let compatible :: Bool
compatible =
case Either ExitCodeException ((), ())
e of
Left ExitCodeException{} -> Bool
False
Right ((), ())
_ -> Bool
True
Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
forall env.
(HasConfig env, HasLogFunc env) =>
Text -> Path Abs File -> UTCTime -> Bool -> RIO env ()
saveDockerImageExeCache
(Inspect -> Text
iiId Inspect
imageInfo)
Path Abs File
exePath
UTCTime
exeTimestamp
Bool
compatible
if Bool
compatible
then [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
else [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env b a.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
Maybe DockerStackExe
Nothing -> [FilePath]
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env b a.
HasConfig env =>
b -> RIO env (FilePath, b, [a], [Mount])
exeDownload [FilePath]
args
where
exeDownload :: b -> RIO env (FilePath, b, [a], [Mount])
exeDownload b
args = do
Path Abs File
exePath <- Platform -> RIO env (Path Abs File)
forall env. HasConfig env => Platform -> RIO env (Path Abs File)
ensureDockerStackExe Platform
dockerContainerPlatform
b -> Path Abs File -> RIO env (FilePath, b, [a], [Mount])
forall (m :: * -> *) b b a.
Monad m =>
b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs b
args Path Abs File
exePath
cmdArgs :: b -> Path b File -> m (FilePath, b, [a], [Mount])
cmdArgs b
args Path b File
exePath = do
#if MIN_VERSION_path(0, 7, 0)
let exeBase :: Path b File
exeBase =
case Path b File -> Either SomeException (Path b File, FilePath)
forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, FilePath)
splitExtension Path b File
exePath of
Left SomeException
_ -> Path b File
exePath
Right (Path b File
x, FilePath
_) -> Path b File
x
#else
exeBase <- exePath -<.> ""
#endif
let mountPath :: FilePath
mountPath = FilePath
hostBinDir FilePath -> FilePath -> FilePath
FP.</> Path Rel File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b File
exeBase)
(FilePath, b, [a], [Mount]) -> m (FilePath, b, [a], [Mount])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
mountPath, b
args, [], [FilePath -> FilePath -> Mount
Mount (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
exePath) FilePath
mountPath])
preventInContainer :: MonadIO m => m () -> m ()
preventInContainer :: m () -> m ()
preventInContainer m ()
inner =
do Bool
inContainer <- m Bool
forall (m :: * -> *). MonadIO m => m Bool
getInContainer
if Bool
inContainer
then StackDockerException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
OnlyOnHostException
else m ()
inner
runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit :: RIO env void
runContainerAndExit = do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
DockerOpts -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
([(FilePath, FilePath)]
env,Bool
isStdinTerminal,Bool
isStderrTerminal,Path Abs Dir
homeDir) <- IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
-> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
-> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
-> RIO env ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
(,,,)
([(FilePath, FilePath)]
-> Bool
-> Bool
-> Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO [(FilePath, FilePath)]
-> IO
(Bool
-> Bool
-> Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, FilePath)]
getEnvironment
IO
(Bool
-> Bool
-> Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO Bool
-> IO
(Bool
-> Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stdin
IO
(Bool
-> Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO Bool
-> IO
(Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDeviceOrMinTTY Handle
stderr
IO
(Path Abs Dir
-> ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir))
-> IO (Path Abs Dir)
-> IO ([(FilePath, FilePath)], Bool, Bool, Path Abs Dir)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
Bool
isStdoutTerminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => Lens' env Bool
terminalL
let dockerHost :: Maybe FilePath
dockerHost = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_HOST" [(FilePath, FilePath)]
env
dockerCertPath :: Maybe FilePath
dockerCertPath = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DOCKER_CERT_PATH" [(FilePath, FilePath)]
env
bamboo :: Maybe FilePath
bamboo = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"bamboo_buildKey" [(FilePath, FilePath)]
env
jenkins :: Maybe FilePath
jenkins = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"JENKINS_HOME" [(FilePath, FilePath)]
env
msshAuthSock :: Maybe FilePath
msshAuthSock = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"SSH_AUTH_SOCK" [(FilePath, FilePath)]
env
muserEnv :: Maybe FilePath
muserEnv = FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"USER" [(FilePath, FilePath)]
env
isRemoteDocker :: Bool
isRemoteDocker = Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"tcp://") Maybe FilePath
dockerHost
Maybe FilePath
mstackYaml <- Maybe FilePath
-> (FilePath -> RIO env FilePath) -> RIO env (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"STACK_YAML" [(FilePath, FilePath)]
env) FilePath -> RIO env FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
RIO.Directory.makeAbsolute
FilePath
image <- (SomeException -> RIO env FilePath)
-> (FilePath -> RIO env FilePath)
-> Either SomeException FilePath
-> RIO env FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env FilePath
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO FilePath -> RIO env FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isRemoteDocker Bool -> Bool -> Bool
&&
Bool -> (FilePath -> Bool) -> Maybe FilePath -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
"boot2docker") Maybe FilePath
dockerCertPath)
(Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Warning: Using boot2docker is NOT supported, and not likely to perform well.")
Maybe Inspect
maybeImageInfo <- FilePath -> RIO env (Maybe Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
imageInfo :: Inspect
imageInfo@Inspect{Maybe Integer
Text
UTCTime
ImageConfig
iiVirtualSize :: Inspect -> Maybe Integer
iiCreated :: Inspect -> UTCTime
iiConfig :: Inspect -> ImageConfig
iiVirtualSize :: Maybe Integer
iiId :: Text
iiCreated :: UTCTime
iiConfig :: ImageConfig
iiId :: Inspect -> Text
..} <- case Maybe Inspect
maybeImageInfo of
Just Inspect
ii -> Inspect -> RIO env Inspect
forall (m :: * -> *) a. Monad m => a -> m a
return Inspect
ii
Maybe Inspect
Nothing
| DockerOpts -> Bool
dockerAutoPull DockerOpts
docker ->
do DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image
Maybe Inspect
mii2 <- FilePath -> RIO env (Maybe Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image
case Maybe Inspect
mii2 of
Just Inspect
ii2 -> Inspect -> RIO env Inspect
forall (m :: * -> *) a. Monad m => a -> m a
return Inspect
ii2
Maybe Inspect
Nothing -> StackDockerException -> RIO env Inspect
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
InspectFailedException FilePath
image)
| Bool
otherwise -> StackDockerException -> RIO env Inspect
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> StackDockerException
NotPulledException FilePath
image)
Path Abs Dir
projectRoot <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
Path Abs Dir
sandboxDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
let ImageConfig {[FilePath]
icEntrypoint :: ImageConfig -> [FilePath]
icEnv :: ImageConfig -> [FilePath]
icEntrypoint :: [FilePath]
icEnv :: [FilePath]
..} = ImageConfig
iiConfig
imageEnvVars :: [(FilePath, FilePath)]
imageEnvVars = (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')) [FilePath]
icEnv
platformVariant :: FilePath
platformVariant = Digest MD5 -> FilePath
forall a. Show a => a -> FilePath
show (Digest MD5 -> FilePath) -> Digest MD5 -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Digest MD5
hashRepoName FilePath
image
stackRoot :: Path Abs Dir
stackRoot = Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config
sandboxHomeDir :: Path Abs Dir
sandboxHomeDir = Path Abs Dir
sandboxDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
homeDirName
isTerm :: Bool
isTerm = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
Bool
isStdinTerminal Bool -> Bool -> Bool
&&
Bool
isStdoutTerminal Bool -> Bool -> Bool
&&
Bool
isStderrTerminal
keepStdinOpen :: Bool
keepStdinOpen = Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker) Bool -> Bool -> Bool
&&
(Bool
isTerm Bool -> Bool -> Bool
|| (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
bamboo Bool -> Bool -> Bool
&& Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing Maybe FilePath
jenkins))
let mpath :: Maybe Text
mpath = FilePath -> Text
T.pack (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
"PATH" [(FilePath, FilePath)]
imageEnvVars
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
mpath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"The Docker image does not set the PATH env var"
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"
Text
newPathEnv <- (ProcessException -> RIO env Text)
-> (Text -> RIO env Text)
-> Either ProcessException Text
-> RIO env Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessException -> RIO env Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Text -> RIO env Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ProcessException Text -> RIO env Text)
-> Either ProcessException Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe Text -> Either ProcessException Text
augmentPath
[ FilePath
hostBinDir
, Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path Abs Dir
sandboxHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotLocal Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBin)]
Maybe Text
mpath
(FilePath
cmnd,[FilePath]
args,[(FilePath, FilePath)]
envVars,[Mount]
extraMount) <- DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker
Path Abs Dir
pwd <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir -> IO ()) -> [Path Abs Dir] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir [Path Abs Dir
sandboxHomeDir, Path Abs Dir
stackRoot]
let sshDir :: Path Abs Dir
sshDir = Path Abs Dir
homeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir
Bool
sshDirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
sshDir
Bool
sshSandboxDirExists <-
IO Bool -> RIO env Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(FilePath -> IO Bool
Files.fileExist
(Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir)))
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
sshDirExists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
sshSandboxDirExists)
(IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(FilePath -> FilePath -> IO ()
Files.createSymbolicLink
(Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sshDir)
(Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep (Path Abs Dir
sandboxHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
sshRelDir))))
let mountSuffix :: FilePath
mountSuffix = FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"" (FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (DockerOpts -> Maybe FilePath
dockerMountMode DockerOpts
docker)
FilePath
containerID <- FilePath -> RIO env FilePath -> RIO env FilePath
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
FilePath -> m a -> m a
withWorkingDir (Path Abs Dir -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Abs Dir
projectRoot) (RIO env FilePath -> RIO env FilePath)
-> RIO env FilePath -> RIO env FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
trim (FilePath -> FilePath)
-> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
decodeUtf8 (ByteString -> FilePath) -> RIO env ByteString -> RIO env FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> RIO env ByteString
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess
([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[[FilePath
"create"
,FilePath
"-e",FilePath
inContainerEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=1"
,FilePath
"-e",FilePath
stackRootEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot
,FilePath
"-e",FilePath
platformVariantEnvVar FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=dk" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
platformVariant
,FilePath
"-e",FilePath
"HOME=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir
,FilePath
"-e",FilePath
"PATH=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
newPathEnv
,FilePath
"-e",FilePath
"PWD=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
pwd
,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
homeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
stackRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
projectRoot FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
,FilePath
"-v",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
sandboxHomeDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix
,FilePath
"-w",Path Abs Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path Abs Dir
pwd]
,case DockerOpts -> Maybe FilePath
dockerNetwork DockerOpts
docker of
Maybe FilePath
Nothing -> [FilePath
"--net=host"]
Just FilePath
name -> [FilePath
"--net=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
,case Maybe FilePath
muserEnv of
Maybe FilePath
Nothing -> []
Just FilePath
userEnv -> [FilePath
"-e",FilePath
"USER=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
userEnv]
,case Maybe FilePath
msshAuthSock of
Maybe FilePath
Nothing -> []
Just FilePath
sshAuthSock ->
[FilePath
"-e",FilePath
"SSH_AUTH_SOCK=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock
,FilePath
"-v",FilePath
sshAuthSock FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
sshAuthSock]
,case Maybe FilePath
mstackYaml of
Maybe FilePath
Nothing -> []
Just FilePath
stackYaml ->
[FilePath
"-e",FilePath
"STACK_YAML=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml
,FilePath
"-v",FilePath
stackYamlFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
stackYaml FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":ro"]
,[FilePath
"--entrypoint=/usr/bin/env"
| Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a. Eq a => a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv FilePath
oldSandboxIdEnvVar [(FilePath, FilePath)]
imageEnvVars) Bool -> Bool -> Bool
&&
([FilePath]
icEntrypoint [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"/usr/local/sbin/docker-entrypoint"] Bool -> Bool -> Bool
||
[FilePath]
icEntrypoint [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
== [FilePath
"/root/entrypoint.sh"])]
,((FilePath, FilePath) -> [FilePath])
-> [(FilePath, FilePath)] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(FilePath
k,FilePath
v) -> [FilePath
"-e", FilePath
k FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
v]) [(FilePath, FilePath)]
envVars
,(Mount -> [FilePath]) -> [Mount] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix) ([Mount]
extraMount [Mount] -> [Mount] -> [Mount]
forall a. [a] -> [a] -> [a]
++ DockerOpts -> [Mount]
dockerMount DockerOpts
docker)
,(FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
nv -> [FilePath
"-e", FilePath
nv]) (DockerOpts -> [FilePath]
dockerEnv DockerOpts
docker)
,case DockerOpts -> Maybe FilePath
dockerContainerName DockerOpts
docker of
Just FilePath
name -> [FilePath
"--name=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name]
Maybe FilePath
Nothing -> []
,[FilePath
"-t" | Bool
isTerm]
,[FilePath
"-i" | Bool
keepStdinOpen]
,DockerOpts -> [FilePath]
dockerRunArgs DockerOpts
docker
,[FilePath
image]
,[FilePath
cmnd]
,[FilePath]
args])
#ifndef WINDOWS
RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
[(CInt, Handler)]
oldHandlers <- [CInt]
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt
sigINT,CInt
sigABRT,CInt
sigHUP,CInt
sigPIPE,CInt
sigTERM,CInt
sigUSR1,CInt
sigUSR2] ((CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)])
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall a b. (a -> b) -> a -> b
$ \CInt
sig -> do
let sigHandler :: IO ()
sigHandler = RIO env () -> IO ()
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
"--signal=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ CInt -> FilePath
forall a. Show a => a -> FilePath
show CInt
sig,FilePath
containerID]
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
sig CInt -> [CInt] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
sigTERM,CInt
sigABRT]) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Int -> RIO env ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
30000000
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"kill",FilePath
containerID]
Handler
oldHandler <- IO Handler -> RIO env Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch IO ()
sigHandler) Maybe SignalSet
forall a. Maybe a
Nothing
(CInt, Handler) -> RIO env (CInt, Handler)
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
sig, Handler
oldHandler)
#endif
let args' :: [FilePath]
args' = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath
"start"]
,[FilePath
"-a" | Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker)]
,[FilePath
"-i" | Bool
keepStdinOpen]
,[FilePath
containerID]]
Either ExitCodeException ()
e <- RIO env () -> RIO env (Either ExitCodeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath]
args' ((ProcessConfig () () () -> RIO env ()) -> RIO env ())
-> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ (ProcessConfig () () () -> RIO env ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
RIO env (Either ExitCodeException ())
-> RIO env () -> RIO env (Either ExitCodeException ())
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally`
(do Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts -> Bool
dockerPersist DockerOpts
docker Bool -> Bool -> Bool
|| DockerOpts -> Bool
dockerDetach DockerOpts
docker) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"docker" [FilePath
"rm",FilePath
"-f",FilePath
containerID]
RIO env () -> (ExitCodeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_::ExitCodeException) -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
#ifndef WINDOWS
[(CInt, Handler)]
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers (((CInt, Handler) -> RIO env Handler) -> RIO env ())
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(CInt
sig,Handler
oldHandler) ->
IO Handler -> RIO env Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler Maybe SignalSet
forall a. Maybe a
Nothing
#endif
)
case Either ExitCodeException ()
e of
Left ExitCodeException{ExitCode
eceExitCode :: ExitCodeException -> ExitCode
eceExitCode :: ExitCode
eceExitCode} -> ExitCode -> RIO env void
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith ExitCode
eceExitCode
Right () -> RIO env void
forall (m :: * -> *) a. MonadIO m => m a
exitSuccess
where
hashRepoName :: String -> Hash.Digest Hash.MD5
hashRepoName :: FilePath -> Digest MD5
hashRepoName = ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash (ByteString -> Digest MD5)
-> (FilePath -> ByteString) -> FilePath -> Digest MD5
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BS.pack (FilePath -> ByteString)
-> (FilePath -> FilePath) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@')
lookupImageEnv :: a -> [(a, FilePath)] -> Maybe FilePath
lookupImageEnv a
name [(a, FilePath)]
vars =
case a -> [(a, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, FilePath)]
vars of
Just (Char
'=':FilePath
val) -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
val
Maybe FilePath
_ -> Maybe FilePath
forall a. Maybe a
Nothing
mountArg :: FilePath -> Mount -> [FilePath]
mountArg FilePath
mountSuffix (Mount FilePath
host FilePath
container) =
[FilePath
"-v",FilePath
host FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
container FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountSuffix]
sshRelDir :: Path Rel Dir
sshRelDir = Path Rel Dir
relDirDotSsh
inspect :: (HasProcessContext env, HasLogFunc env)
=> String -> RIO env (Maybe Inspect)
inspect :: FilePath -> RIO env (Maybe Inspect)
inspect FilePath
image =
do Map Text Inspect
results <- [FilePath] -> RIO env (Map Text Inspect)
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [FilePath
image]
case Map Text Inspect -> [(Text, Inspect)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text Inspect
results of
[] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Inspect
forall a. Maybe a
Nothing
[(Text
_,Inspect
i)] -> Maybe Inspect -> RIO env (Maybe Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return (Inspect -> Maybe Inspect
forall a. a -> Maybe a
Just Inspect
i)
[(Text, Inspect)]
_ -> StackDockerException -> RIO env (Maybe Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
InvalidInspectOutputException FilePath
"expect a single result")
inspects :: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env (Map Text Inspect)
inspects :: [FilePath] -> RIO env (Map Text Inspect)
inspects [] = Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Inspect
forall k a. Map k a
Map.empty
inspects [FilePath]
images =
do Either ExitCodeException ByteString
maybeInspectOut <-
RIO env ByteString -> RIO env (Either ExitCodeException ByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> RIO env (ByteString, ByteString) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" (FilePath
"inspect" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
images) ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_)
case Either ExitCodeException ByteString
maybeInspectOut of
Right ByteString
inspectOut ->
case ByteString -> Either FilePath [Inspect]
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode (FilePath -> ByteString
LBS.pack ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isAscii (ByteString -> FilePath
decodeUtf8 ByteString
inspectOut))) of
Left FilePath
msg -> StackDockerException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
InvalidInspectOutputException FilePath
msg)
Right [Inspect]
results -> Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Inspect)] -> Map Text Inspect
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Inspect -> (Text, Inspect)) -> [Inspect] -> [(Text, Inspect)]
forall a b. (a -> b) -> [a] -> [b]
map (\Inspect
r -> (Inspect -> Text
iiId Inspect
r,Inspect
r)) [Inspect]
results))
Left ExitCodeException
ece
| (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`LBS.isPrefixOf` ExitCodeException -> ByteString
eceStderr ExitCodeException
ece) [ByteString]
missingImagePrefixes -> Map Text Inspect -> RIO env (Map Text Inspect)
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text Inspect
forall k a. Map k a
Map.empty
Left ExitCodeException
e -> ExitCodeException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ExitCodeException
e
where missingImagePrefixes :: [ByteString]
missingImagePrefixes = [ByteString
"Error: No such image", ByteString
"Error: No such object:"]
pull :: HasConfig env => RIO env ()
pull :: RIO env ()
pull =
do Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
configL
let docker :: DockerOpts
docker = Config -> DockerOpts
configDocker Config
config
DockerOpts -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker
(SomeException -> RIO env ())
-> (FilePath -> RIO env ())
-> Either SomeException FilePath
-> RIO env ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker) (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)
pullImage :: (HasProcessContext env, HasLogFunc env)
=> DockerOpts -> String -> RIO env ()
pullImage :: DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image =
do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"Pulling image from registry: '" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
image Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"'")
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DockerOpts -> Bool
dockerRegistryLogin DockerOpts
docker)
(do Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"You may need to log in."
FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ())
-> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc
FilePath
"docker"
([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[[FilePath
"login"]
,[FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
n -> [FilePath
"--username=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
n]) (DockerOpts -> Maybe FilePath
dockerRegistryUsername DockerOpts
docker)
,[FilePath]
-> (FilePath -> [FilePath]) -> Maybe FilePath -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
p -> [FilePath
"--password=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
p]) (DockerOpts -> Maybe FilePath
dockerRegistryPassword DockerOpts
docker)
,[(Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') FilePath
image]])
ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_)
ExitCode
ec <- FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath
"pull", FilePath
image] ((ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode)
-> (ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
let pc :: ProcessConfig () () ()
pc = StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
(ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr)
(ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed
ProcessConfig () () ()
pc0
ProcessConfig () () () -> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ExitCode
runProcess ProcessConfig () () ()
pc
case ExitCode
ec of
ExitCode
ExitSuccess -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> StackDockerException
PullFailedException FilePath
image)
checkDockerVersion
:: (HasProcessContext env, HasLogFunc env)
=> DockerOpts -> RIO env ()
checkDockerVersion :: DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker =
do Bool
dockerExists <- FilePath -> RIO env Bool
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
FilePath -> m Bool
doesExecutableExist FilePath
"docker"
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dockerExists (StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
DockerNotInstalledException)
ByteString
dockerVersionOut <- [FilePath] -> RIO env ByteString
forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath
"--version"]
case FilePath -> [FilePath]
words (ByteString -> FilePath
decodeUtf8 ByteString
dockerVersionOut) of
(FilePath
_:FilePath
_:FilePath
v:[FilePath]
_) ->
case (Version -> Version) -> Maybe Version -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> Version
mkVersion' (Maybe Version -> Maybe Version) -> Maybe Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Version
parseVersion' (FilePath -> Maybe Version) -> FilePath -> Maybe Version
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
stripVersion FilePath
v of
Just Version
v'
| Version
v' Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
minimumDockerVersion ->
StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> StackDockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
| Version
v' Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
forall a. [a]
prohibitedDockerVersions ->
StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> StackDockerException
DockerVersionProhibitedException [Version]
forall a. [a]
prohibitedDockerVersions Version
v')
| Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) ->
StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (VersionRange -> Version -> StackDockerException
BadDockerVersionException (DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) Version
v')
| Bool
otherwise ->
() -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Version
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
InvalidVersionOutputException
[FilePath]
_ -> StackDockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
InvalidVersionOutputException
where minimumDockerVersion :: Version
minimumDockerVersion = [Int] -> Version
mkVersion [Int
1, Int
6, Int
0]
prohibitedDockerVersions :: [a]
prohibitedDockerVersions = []
stripVersion :: FilePath -> FilePath
stripVersion FilePath
v = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') ((Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) FilePath
v)
parseVersion' :: FilePath -> Maybe Version
parseVersion' = ((Version, FilePath) -> Version)
-> Maybe (Version, FilePath) -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version, FilePath) -> Version
forall a b. (a, b) -> a
fst (Maybe (Version, FilePath) -> Maybe Version)
-> (FilePath -> Maybe (Version, FilePath))
-> FilePath
-> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Version, FilePath)] -> Maybe (Version, FilePath)
forall a. [a] -> Maybe a
listToMaybe ([(Version, FilePath)] -> Maybe (Version, FilePath))
-> (FilePath -> [(Version, FilePath)])
-> FilePath
-> Maybe (Version, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Version, FilePath)] -> [(Version, FilePath)]
forall a. [a] -> [a]
reverse ([(Version, FilePath)] -> [(Version, FilePath)])
-> (FilePath -> [(Version, FilePath)])
-> FilePath
-> [(Version, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP Version -> FilePath -> [(Version, FilePath)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP Version
Data.Version.parseVersion
reset :: HasConfig env => Bool -> RIO env ()
reset :: Bool -> RIO env ()
reset Bool
keepHome = do
Path Abs Dir
projectRoot <- RIO env (Path Abs Dir)
forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot
Path Abs Dir
dockerSandboxDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(MonadReader env m, HasConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> IO ()
removeDirectoryContents
Path Abs Dir
dockerSandboxDir
[Path Rel Dir
homeDirName | Bool
keepHome]
[])
entrypoint :: (HasProcessContext env, HasLogFunc env)
=> Config -> DockerEntrypoint -> RIO env ()
entrypoint :: Config -> DockerEntrypoint -> RIO env ()
entrypoint config :: Config
config@Config{Bool
Int
[FilePath]
Maybe (Path Abs File)
Maybe CompilerBuild
Maybe AbstractResolver
Maybe TemplateName
Maybe GHCVariant
Maybe SCM
Platform
VersionRange
Map (Maybe PackageName) Bool
Map PackageName [Text]
Map Text Text
Map ApplyGhcOptions [Text]
Map CabalConfigKey [Text]
Text
PantryConfig
Path Abs File
Path Abs Dir
Path Rel Dir
BuildOpts
NixOpts
VersionCheck
DockerOpts
CompilerRepository
PvpBounds
SetupInfo
PlatformVariant
ProjectConfig (Project, Path Abs File)
DumpLogs
ApplyGhcOptions
UserStorage
Runner
EnvSettings -> IO ProcessContext
configStackDeveloperMode :: Config -> Bool
configRecommendUpgrade :: Config -> Bool
configHideSourcePaths :: Config -> Bool
configUserStorage :: Config -> UserStorage
configResolver :: Config -> Maybe AbstractResolver
configStackRoot :: Config -> Path Abs Dir
configPantryConfig :: Config -> PantryConfig
configRunner :: Config -> Runner
configHackageBaseUrl :: Config -> Text
configSaveHackageCreds :: Config -> Bool
configAllowLocals :: Config -> Bool
configProject :: Config -> ProjectConfig (Project, Path Abs File)
configDumpLogs :: Config -> DumpLogs
configAllowDifferentUser :: Config -> Bool
configDefaultTemplate :: Config -> Maybe TemplateName
configAllowNewer :: Config -> Bool
configApplyGhcOptions :: Config -> ApplyGhcOptions
configRebuildGhcOptions :: Config -> Bool
configExplicitSetupDeps :: Config -> Map (Maybe PackageName) Bool
configModifyCodePage :: Config -> Bool
configPvpBounds :: Config -> PvpBounds
configSetupInfoInline :: Config -> SetupInfo
configSetupInfoLocations :: Config -> [FilePath]
configCabalConfigOpts :: Config -> Map CabalConfigKey [Text]
configGhcOptionsByCat :: Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Config -> Map PackageName [Text]
configScmInit :: Config -> Maybe SCM
configTemplateParams :: Config -> Map Text Text
configConcurrentTests :: Config -> Bool
configExtraLibDirs :: Config -> [FilePath]
configExtraIncludeDirs :: Config -> [FilePath]
configOverrideGccPath :: Config -> Maybe (Path Abs File)
configJobs :: Config -> Int
configRequireStackVersion :: Config -> VersionRange
configLocalBin :: Config -> Path Abs Dir
configCompilerRepository :: Config -> CompilerRepository
configCompilerCheck :: Config -> VersionCheck
configSkipMsys :: Config -> Bool
configSkipGHCCheck :: Config -> Bool
configInstallGHC :: Config -> Bool
configSystemGHC :: Config -> Bool
configLatestSnapshot :: Config -> Text
configGHCBuild :: Config -> Maybe CompilerBuild
configGHCVariant :: Config -> Maybe GHCVariant
configPlatformVariant :: Config -> PlatformVariant
configPrefixTimestamps :: Config -> Bool
configHideTHLoading :: Config -> Bool
configLocalPrograms :: Config -> Path Abs Dir
configLocalProgramsBase :: Config -> Path Abs Dir
configProcessContextSettings :: Config -> EnvSettings -> IO ProcessContext
configNix :: Config -> NixOpts
configBuild :: Config -> BuildOpts
configUserConfigPath :: Config -> Path Abs File
configWorkDir :: Config -> Path Rel Dir
configStackDeveloperMode :: Bool
configRecommendUpgrade :: Bool
configHideSourcePaths :: Bool
configUserStorage :: UserStorage
configResolver :: Maybe AbstractResolver
configStackRoot :: Path Abs Dir
configPantryConfig :: PantryConfig
configRunner :: Runner
configHackageBaseUrl :: Text
configSaveHackageCreds :: Bool
configAllowLocals :: Bool
configProject :: ProjectConfig (Project, Path Abs File)
configDumpLogs :: DumpLogs
configAllowDifferentUser :: Bool
configDefaultTemplate :: Maybe TemplateName
configAllowNewer :: Bool
configApplyGhcOptions :: ApplyGhcOptions
configRebuildGhcOptions :: Bool
configExplicitSetupDeps :: Map (Maybe PackageName) Bool
configModifyCodePage :: Bool
configPvpBounds :: PvpBounds
configSetupInfoInline :: SetupInfo
configSetupInfoLocations :: [FilePath]
configCabalConfigOpts :: Map CabalConfigKey [Text]
configGhcOptionsByCat :: Map ApplyGhcOptions [Text]
configGhcOptionsByName :: Map PackageName [Text]
configScmInit :: Maybe SCM
configTemplateParams :: Map Text Text
configConcurrentTests :: Bool
configExtraLibDirs :: [FilePath]
configExtraIncludeDirs :: [FilePath]
configOverrideGccPath :: Maybe (Path Abs File)
configJobs :: Int
configRequireStackVersion :: VersionRange
configLocalBin :: Path Abs Dir
configCompilerRepository :: CompilerRepository
configCompilerCheck :: VersionCheck
configSkipMsys :: Bool
configSkipGHCCheck :: Bool
configInstallGHC :: Bool
configSystemGHC :: Bool
configLatestSnapshot :: Text
configGHCBuild :: Maybe CompilerBuild
configGHCVariant :: Maybe GHCVariant
configPlatformVariant :: PlatformVariant
configPlatform :: Platform
configPrefixTimestamps :: Bool
configHideTHLoading :: Bool
configLocalPrograms :: Path Abs Dir
configLocalProgramsBase :: Path Abs Dir
configProcessContextSettings :: EnvSettings -> IO ProcessContext
configNix :: NixOpts
configDocker :: DockerOpts
configBuild :: BuildOpts
configUserConfigPath :: Path Abs File
configWorkDir :: Path Rel Dir
configPlatform :: Config -> Platform
configDocker :: Config -> DockerOpts
..} DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: DockerEntrypoint -> Maybe DockerUser
..} =
MVar Bool -> (Bool -> RIO env Bool) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
MVar a -> (a -> m a) -> m ()
modifyMVar_ MVar Bool
entrypointMVar ((Bool -> RIO env Bool) -> RIO env ())
-> (Bool -> RIO env Bool) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Bool
alreadyRan -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyRan (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
ProcessContext
envOverride <- Getting ProcessContext env ProcessContext -> RIO env ProcessContext
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProcessContext env ProcessContext
forall env. HasProcessContext env => Lens' env ProcessContext
processContextL
Path Abs Dir
homeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> RIO env (Path Abs Dir))
-> IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (FilePath -> IO (Path Abs Dir)) -> IO FilePath -> IO (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
getEnv FilePath
"HOME"
Either () UserEntry
estackUserEntry0 <- IO (Either () UserEntry) -> RIO env (Either () UserEntry)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () UserEntry) -> RIO env (Either () UserEntry))
-> IO (Either () UserEntry) -> RIO env (Either () UserEntry)
forall a b. (a -> b) -> a -> b
$ (IOError -> Maybe ()) -> IO UserEntry -> IO (Either () UserEntry)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO UserEntry -> IO (Either () UserEntry))
-> IO UserEntry -> IO (Either () UserEntry)
forall a b. (a -> b) -> a -> b
$
FilePath -> IO UserEntry
User.getUserEntryForName FilePath
stackUserName
case Maybe DockerUser
deUser of
Maybe DockerUser
Nothing -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just DockerUser
du -> ProcessContext -> RIO env () -> RIO env ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
envOverride (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Either () UserEntry -> Path Abs Dir -> DockerUser -> RIO env ()
forall env a b loc.
(HasProcessContext env, HasLogFunc env) =>
Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either () UserEntry
estackUserEntry0 Path Abs Dir
homeDir DockerUser
du
case Either () UserEntry
estackUserEntry0 of
Left ()
_ -> () -> RIO env ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right UserEntry
ue -> do
Path Abs Dir
origStackHomeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> RIO env (Path Abs Dir))
-> IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir (UserEntry -> FilePath
User.homeDirectory UserEntry
ue)
let origStackRoot :: Path Abs Dir
origStackRoot = Path Abs Dir
origStackHomeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDotStackProgName
Bool
buildPlanDirExists <- Path Abs Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildPlanDirExists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
([Path Abs Dir]
_, [Path Abs File]
buildPlans) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir (Path Abs Dir -> Path Abs Dir
buildPlanDir Path Abs Dir
origStackRoot)
[Path Abs File] -> (Path Abs File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
buildPlans ((Path Abs File -> RIO env ()) -> RIO env ())
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs File
srcBuildPlan -> do
let destBuildPlan :: Path Abs File
destBuildPlan = Path Abs Dir -> Path Abs Dir
buildPlanDir (Getting (Path Abs Dir) Config (Path Abs Dir)
-> Config -> Path Abs Dir
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) Config (Path Abs Dir)
forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config) Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
srcBuildPlan
Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
destBuildPlan
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
destBuildPlan)
Path Abs File -> Path Abs File -> RIO env ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
srcBuildPlan Path Abs File
destBuildPlan
Bool -> RIO env Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
updateOrCreateStackUser :: Either a b -> Path loc Dir -> DockerUser -> RIO env ()
updateOrCreateStackUser Either a b
estackUserEntry Path loc Dir
homeDir DockerUser{[GroupID]
FileMode
GroupID
UserID
duUmask :: FileMode
duGroups :: [GroupID]
duGid :: GroupID
duUid :: UserID
duUmask :: DockerUser -> FileMode
duGroups :: DockerUser -> [GroupID]
duGid :: DockerUser -> GroupID
duUid :: DockerUser -> UserID
..} = do
case Either a b
estackUserEntry of
Left a
_ -> do
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupadd"
[FilePath
"-o"
,FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
duGid
,FilePath
stackUserName]
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"useradd"
[FilePath
"-oN"
,FilePath
"--uid",UserID -> FilePath
forall a. Show a => a -> FilePath
show UserID
duUid
,FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
duGid
,FilePath
"--home",Path loc Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path loc Dir
homeDir
,FilePath
stackUserName]
Right b
_ -> do
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"usermod"
[FilePath
"-o"
,FilePath
"--uid",UserID -> FilePath
forall a. Show a => a -> FilePath
show UserID
duUid
,FilePath
"--home",Path loc Dir -> FilePath
forall loc. Path loc Dir -> FilePath
toFilePathNoTrailingSep Path loc Dir
homeDir
,FilePath
stackUserName]
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupmod"
[FilePath
"-o"
,FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
duGid
,FilePath
stackUserName]
[GroupID] -> (GroupID -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [GroupID]
duGroups ((GroupID -> RIO env ()) -> RIO env ())
-> (GroupID -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \GroupID
gid -> do
FilePath -> [FilePath] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
FilePath -> [FilePath] -> RIO env ()
readProcessNull FilePath
"groupadd"
[FilePath
"-o"
,FilePath
"--gid",GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
gid
,FilePath
"group" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ GroupID -> FilePath
forall a. Show a => a -> FilePath
show GroupID
gid]
IO () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
GroupID -> IO ()
User.setGroupID GroupID
duGid
#ifndef WINDOWS
[GroupID] -> IO ()
PosixUser.setGroups [GroupID]
duGroups
#endif
UserID -> IO ()
User.setUserID UserID
duUid
FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
stackUserName :: FilePath
stackUserName = FilePath
"stack"::String
entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar :: MVar Bool
entrypointMVar = IO (MVar Bool) -> MVar Bool
forall a. IO a -> a
unsafePerformIO (Bool -> IO (MVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Bool
False)
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 <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
path
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isRootDir
(do ([Path Abs Dir]
lsd,[Path Abs File]
lsf) <- Path Abs Dir -> IO ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
path
[Path Abs Dir] -> (Path Abs Dir -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs Dir]
lsd
(\Path Abs Dir
d -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
d Path Rel Dir -> [Path Rel Dir] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel Dir]
excludeDirs)
(Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
d))
[Path Abs File] -> (Path Abs File -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
lsf
(\Path Abs File
f -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Abs File
f Path Rel File -> [Path Rel File] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Path Rel File]
excludeFiles)
(Path Abs File -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
f)))
readDockerProcess
:: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env BS.ByteString
readDockerProcess :: [FilePath] -> RIO env ByteString
readDockerProcess [FilePath]
args = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> RIO env ByteString -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env ByteString)
-> RIO env ByteString
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc FilePath
"docker" [FilePath]
args ProcessConfig () () () -> RIO env ByteString
forall (m :: * -> *) stdin stdoutIgnored stderr.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderr -> m ByteString
readProcessStdout_
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 :: RIO env (Path Abs Dir)
getProjectRoot = do
Maybe (Path Abs Dir)
mroot <- Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
-> RIO env (Maybe (Path Abs Dir))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
-> RIO env (Maybe (Path Abs Dir)))
-> Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
-> RIO env (Maybe (Path Abs Dir))
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Maybe (Path Abs Dir)) Config)
-> env -> Const (Maybe (Path Abs Dir)) env
forall env. HasConfig env => Lens' env Config
configL((Config -> Const (Maybe (Path Abs Dir)) Config)
-> env -> Const (Maybe (Path Abs Dir)) env)
-> ((Maybe (Path Abs Dir)
-> Const (Maybe (Path Abs Dir)) (Maybe (Path Abs Dir)))
-> Config -> Const (Maybe (Path Abs Dir)) Config)
-> Getting (Maybe (Path Abs Dir)) env (Maybe (Path Abs Dir))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Maybe (Path Abs Dir))
-> SimpleGetter Config (Maybe (Path Abs Dir))
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Maybe (Path Abs Dir)
configProjectRoot
RIO env (Path Abs Dir)
-> (Path Abs Dir -> RIO env (Path Abs Dir))
-> Maybe (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (StackDockerException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO StackDockerException
CannotDetermineProjectRootException) Path Abs Dir -> RIO env (Path Abs Dir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
mroot
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
(Int -> Inspect -> FilePath -> FilePath)
-> (Inspect -> FilePath)
-> ([Inspect] -> FilePath -> FilePath)
-> Show Inspect
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Inspect] -> FilePath -> FilePath
$cshowList :: [Inspect] -> FilePath -> FilePath
show :: Inspect -> FilePath
$cshow :: Inspect -> FilePath
showsPrec :: Int -> Inspect -> FilePath -> FilePath
$cshowsPrec :: Int -> Inspect -> FilePath -> FilePath
Show)
instance FromJSON Inspect where
parseJSON :: Value -> Parser Inspect
parseJSON Value
v =
do Object
o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
ImageConfig -> UTCTime -> Text -> Maybe Integer -> Inspect
Inspect (ImageConfig -> UTCTime -> Text -> Maybe Integer -> Inspect)
-> Parser ImageConfig
-> Parser (UTCTime -> Text -> Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser ImageConfig
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Config"
Parser (UTCTime -> Text -> Maybe Integer -> Inspect)
-> Parser UTCTime -> Parser (Text -> Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser UTCTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Created"
Parser (Text -> Maybe Integer -> Inspect)
-> Parser Text -> Parser (Maybe Integer -> Inspect)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"Id"
Parser (Maybe Integer -> Inspect)
-> Parser (Maybe Integer) -> Parser Inspect
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"VirtualSize"
data ImageConfig = ImageConfig
{ImageConfig -> [FilePath]
icEnv :: [String]
,ImageConfig -> [FilePath]
icEntrypoint :: [String]}
deriving (Int -> ImageConfig -> FilePath -> FilePath
[ImageConfig] -> FilePath -> FilePath
ImageConfig -> FilePath
(Int -> ImageConfig -> FilePath -> FilePath)
-> (ImageConfig -> FilePath)
-> ([ImageConfig] -> FilePath -> FilePath)
-> Show ImageConfig
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ImageConfig] -> FilePath -> FilePath
$cshowList :: [ImageConfig] -> FilePath -> FilePath
show :: ImageConfig -> FilePath
$cshow :: ImageConfig -> FilePath
showsPrec :: Int -> ImageConfig -> FilePath -> FilePath
$cshowsPrec :: Int -> ImageConfig -> FilePath -> FilePath
Show)
instance FromJSON ImageConfig where
parseJSON :: Value -> Parser ImageConfig
parseJSON Value
v =
do Object
o <- Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
[FilePath] -> [FilePath] -> ImageConfig
ImageConfig
([FilePath] -> [FilePath] -> ImageConfig)
-> Parser [FilePath] -> Parser ([FilePath] -> ImageConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Maybe [FilePath]) -> Maybe [FilePath])
-> Parser (Maybe (Maybe [FilePath])) -> Parser (Maybe [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [FilePath]) -> Maybe [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o Object -> Text -> Parser (Maybe (Maybe [FilePath]))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Env") Parser (Maybe [FilePath]) -> [FilePath] -> Parser [FilePath]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
Parser ([FilePath] -> ImageConfig)
-> Parser [FilePath] -> Parser ImageConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe (Maybe [FilePath]) -> Maybe [FilePath])
-> Parser (Maybe (Maybe [FilePath])) -> Parser (Maybe [FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [FilePath]) -> Maybe [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Object
o Object -> Text -> Parser (Maybe (Maybe [FilePath]))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"Entrypoint") Parser (Maybe [FilePath]) -> [FilePath] -> Parser [FilePath]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []