{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}

-- | Run commands in Docker containers

module Stack.Docker
  ( dockerCmdName
  , dockerHelpOptName
  , dockerPullCmdName
  , entrypoint
  , preventInContainer
  , pull
  , reset
  , reExecArgName
  , DockerException (..)
  , getProjectRoot
  , runContainerAndExit
  ) where

import qualified Crypto.Hash as Hash ( Digest, MD5, hash )
import           Data.Aeson ( eitherDecode )
import           Data.Aeson.Types ( FromJSON (..), (.!=) )
import           Data.Aeson.WarningParser ( (.:), (.:?) )
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.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           Path
                   ( (</>), dirname, filename, parent, parseAbsDir
                   , splitExtension
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( copyFile, doesDirExist, doesFileExist, ensureDir
                   , getCurrentDir, getHomeDir, getModificationTime, listDir
                   , removeDirRecur, removeFile, resolveFile'
                   )
import qualified RIO.Directory ( makeAbsolute )
import           RIO.Process
                   ( ExitCodeException (..), HasProcessContext, augmentPath
                   , closed, doesExecutableExist, proc, processContextL
                   , readProcessStdout_, readProcess_, runProcess, runProcess_
                   , setStderr, setStdin, setStdout, useHandleOpen
                   , withWorkingDir
                   )
import           Stack.Config ( getInContainer )
import           Stack.Constants
                   ( buildPlanDir, inContainerEnvVar, platformVariantEnvVar
                   , relDirBin, relDirDotLocal, relDirDotSsh
                   , relDirDotStackProgName, relDirUnderHome, stackRootEnvVar
                   )
import           Stack.Constants.Config ( projectDockerSandboxDir )
import           Stack.Docker.Handlers ( handleSetGroups, handleSignals )
import           Stack.Prelude
import           Stack.Setup ( ensureDockerStackExe )
import           Stack.Storage.User
                   ( loadDockerImageExeCache, saveDockerImageExeCache )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), configProjectRoot, stackRootL
                   )
import           Stack.Types.Docker
                  ( DockerException (..), DockerOpts (..), DockerStackExe (..)
                  , Mount (..), dockerCmdName, dockerContainerPlatform
                  , dockerEntrypointArgName, dockerHelpOptName
                  , dockerPullCmdName, reExecArgName
                  )
import           Stack.Types.DockerEntrypoint
                   ( DockerEntrypoint (..), DockerUser (..) )
import           Stack.Types.Runner ( terminalL )
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 )
import qualified System.Posix.User as User
import qualified System.PosixCompat.Files as Files
import           System.Terminal ( hIsTerminalDeviceOrMinTTY )
import           Text.ParserCombinators.ReadP ( readP_to_S )

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

getCmdArgs ::
     HasConfig env
  => DockerOpts
  -> Inspect
  -> Bool
  -> RIO env (FilePath,[String],[(String,String)],[Mount])
getCmdArgs :: forall env.
HasConfig env =>
DockerOpts
-> Inspect
-> Bool
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
getCmdArgs DockerOpts
docker Inspect
imageInfo Bool
isRemoteDocker = do
    Config
config <- 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
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 a. IO a -> RIO env a
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
              -- Only way to get old umask seems to be to change it, so set it back afterward

              FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
              Maybe DockerUser -> IO (Maybe DockerUser)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DockerUser -> Maybe DockerUser
forall a. a -> Maybe a
Just DockerUser{[GroupID]
FileMode
GroupID
UserID
duUid :: UserID
duGid :: GroupID
duGroups :: [GroupID]
duUmask :: FileMode
duUid :: UserID
duGid :: GroupID
duGroups :: [GroupID]
duUmask :: FileMode
..})
            else Maybe DockerUser -> RIO env (Maybe DockerUser)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DockerUser
forall a. Maybe a
Nothing
    [FilePath]
args <-
        ([FilePath] -> [FilePath])
-> RIO env [FilePath] -> RIO env [FilePath]
forall a b. (a -> b) -> RIO env a -> RIO env b
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]
++ FilePath
showStackVersion
             ,FilePath
"--" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dockerEntrypointArgName
             ,DockerEntrypoint -> FilePath
forall a. Show a => a -> FilePath
show DockerEntrypoint{Maybe DockerUser
deUser :: Maybe DockerUser
deUser :: Maybe DockerUser
..}] ++)
            (IO [FilePath] -> RIO env [FilePath]
forall a. IO a -> RIO env 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 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 a. IO a -> RIO env a
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 {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs [FilePath]
args Path Abs File
exePath
          | Bool
otherwise -> DockerException
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
UnsupportedStackExeHostPlatformException
        Just DockerStackExe
DockerStackExeImage -> do
            FilePath
progName <- IO FilePath -> RIO env FilePath
forall a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> FilePath
FP.takeBaseName FilePath
progName, [FilePath]
args, [], [])
        Just (DockerStackExePath Path Abs File
path) -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
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 -> [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 a. IO a -> RIO env a
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 a. a -> RIO env a
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 -> [FilePath]
-> Path Abs File
-> RIO env (FilePath, [FilePath], [(FilePath, FilePath)], [Mount])
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 -> [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 {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (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 {f :: * -> *} {b} {b} {a}.
Applicative f =>
b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path Abs File
exePath
    cmdArgs :: b -> Path b File -> f (FilePath, b, [a], [Mount])
cmdArgs b
args Path b File
exePath = do
        -- MSS 2020-04-21 previously used replaceExtension, but semantics changed in path 0.7

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

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

        let exeBase :: Path b File
exeBase =
              case 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
        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]) -> f (FilePath, b, [a], [Mount])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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])

-- | Error if running in a container.

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

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

runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit :: forall env void. HasConfig env => RIO env void
runContainerAndExit = do
  Config
config <- 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
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 a. IO a -> RIO env a
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 a b. IO (a -> b) -> IO a -> IO b
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 a b. IO (a -> b) -> IO a -> IO b
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 a b. IO (a -> b) -> IO a -> IO b
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
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 a. a -> RIO env a
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 )
    ( FilePath -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyWarnS
        FilePath
"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
iiId :: Inspect -> Text
iiConfig :: ImageConfig
iiCreated :: UTCTime
iiId :: Text
iiVirtualSize :: Maybe Integer
iiConfig :: Inspect -> ImageConfig
iiCreated :: Inspect -> UTCTime
iiVirtualSize :: Inspect -> Maybe Integer
..} <- case Maybe Inspect
maybeImageInfo of
    Just Inspect
ii -> Inspect -> RIO env Inspect
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii
    Maybe Inspect
Nothing
      | DockerOpts -> Bool
dockerAutoPull DockerOpts
docker -> do
          DockerOpts -> FilePath -> RIO env ()
forall env.
(HasProcessContext env, HasTerm 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Inspect
ii2
            Maybe Inspect
Nothing -> DockerException -> RIO env Inspect
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
InspectFailedException FilePath
image)
      | Bool
otherwise -> DockerException -> RIO env Inspect
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (FilePath -> DockerException
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 :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
  let ImageConfig {[FilePath]
icEnv :: [FilePath]
icEntrypoint :: [FilePath]
icEnv :: ImageConfig -> [FilePath]
icEntrypoint :: ImageConfig -> [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)
Lens' Config (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
&&
                      -- Workaround for https://github.com/docker/docker/issues/12319

                      -- This is fixed in Docker 1.9.1, but will leave the workaround

                      -- in place for now, for users who haven't upgraded yet.

                      (Bool
isTerm Bool -> Bool -> Bool
|| (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
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
      [ FilePath -> StyleDoc
flow FilePath
"The Docker image does not set the PATH environment variable. \
             \This will likely fail. For further information, see"
      , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/issues/2742" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
      ]
  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 e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Text -> RIO env Text
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. IO a -> RIO env a
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]
  -- Since $HOME is now mounted in the same place in the container we can

  -- just symlink $HOME/.ssh to the right place for the stack docker user

  let sshDir :: Path Abs Dir
sshDir = Path Abs Dir
homeDir 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 a. IO a -> RIO env a
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 a. IO a -> RIO env a
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
":" ++) (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"
              ]
           -- Disable the deprecated entrypoint in FP Complete-generated images

        , [ 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
        ]
      )
  Either ExitCodeException ()
e <- DockerOpts
-> Bool -> FilePath -> RIO env (Either ExitCodeException ())
forall e env.
(Exception e, HasConfig env) =>
DockerOpts -> Bool -> FilePath -> RIO env (Either e ())
handleSignals DockerOpts
docker Bool
keepStdinOpen FilePath
containerID
  case Either ExitCodeException ()
e of
    Left ExitCodeException{ExitCode
eceExitCode :: ExitCode
eceExitCode :: ExitCodeException -> 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
    -- This is using a hash of the Docker repository (without tag or digest) to

    -- ensure binaries/libraries aren't shared between Docker and host (or

    -- incompatible Docker images)

    hashRepoName :: String -> Hash.Digest Hash.MD5
    hashRepoName :: FilePath -> Digest MD5
hashRepoName = 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 Docker image or container.

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

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

inspects :: (HasProcessContext env, HasLogFunc env)
         => [String]
         -> RIO env (Map Text Inspect)
inspects :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env (Map Text Inspect)
inspects [] = Map Text Inspect -> RIO env (Map Text Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Inspect
forall k a. Map k a
Map.empty
inspects [FilePath]
images = do
  Either ExitCodeException ByteString
maybeInspectOut <-
    -- not using 'readDockerProcess' as the error from a missing image

    -- needs to be recovered.

    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 ->
      -- filtering with 'isAscii' to workaround @docker inspect@ output

      -- containing invalid UTF-8

      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 -> DockerException -> RIO env (Map Text Inspect)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
InvalidInspectOutputException FilePath
msg)
        Right [Inspect]
results -> Map Text Inspect -> RIO env (Map Text Inspect)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 latest version of configured Docker image from registry.

pull :: HasConfig env => RIO env ()
pull :: forall env. HasConfig env => 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
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, HasTerm env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker) (DockerOpts -> Either SomeException FilePath
dockerImage DockerOpts
docker)

-- | Pull Docker image from registry.

pullImage :: (HasProcessContext env, HasTerm env)
          => DockerOpts
          -> String
          -> RIO env ()
pullImage :: forall env.
(HasProcessContext env, HasTerm env) =>
DockerOpts -> FilePath -> RIO env ()
pullImage DockerOpts
docker FilePath
image = do
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ FilePath -> StyleDoc
flow FilePath
"Pulling image from registry:"
    , Style -> StyleDoc -> StyleDoc
style Style
Current (FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString FilePath
image) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DockerOpts -> Bool
dockerRegistryLogin DockerOpts
docker) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
FilePath -> m ()
prettyInfoS FilePath
"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_
  -- We redirect the stdout of the process to stderr so that the output

  -- of @docker pull@ will not interfere with the output of other

  -- commands when using --auto-docker-pull. See issue #2733.

  ExitCode
ec <- 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ExitFailure Int
_ -> DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FilePath -> DockerException
PullFailedException FilePath
image)

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

checkDockerVersion ::
     (HasProcessContext env, HasLogFunc env)
  => DockerOpts
  -> RIO env ()
checkDockerVersion :: forall env.
(HasProcessContext env, HasLogFunc env) =>
DockerOpts -> RIO env ()
checkDockerVersion DockerOpts
docker = do
  Bool
dockerExists <- 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 (DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
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 a b. (a -> b) -> Maybe a -> Maybe b
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 ->
            DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Version -> Version -> DockerException
DockerTooOldException Version
minimumDockerVersion Version
v')
          | Version
v' Version -> [Version] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
forall a. [a]
prohibitedDockerVersions ->
            DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([Version] -> Version -> DockerException
DockerVersionProhibitedException [Version]
forall a. [a]
prohibitedDockerVersions Version
v')
          | Bool -> Bool
not (Version
v' Version -> VersionRange -> Bool
`withinRange` DockerOpts -> VersionRange
dockerRequireDockerVersion DockerOpts
docker) ->
            DockerException -> RIO env ()
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 ->
            () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe Version
_ -> DockerException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
InvalidVersionOutputException
    [FilePath]
_ -> DockerException -> RIO env ()
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 = (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)
  -- version is parsed by Data.Version provided code to avoid

  -- Cabal's Distribution.Version lack of support for leading zeros in version

  parseVersion' :: FilePath -> Maybe Version
parseVersion' =
    ((Version, FilePath) -> Version)
-> Maybe (Version, FilePath) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
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

-- | Remove the project's Docker sandbox.

reset :: HasConfig env => Bool -> RIO env ()
reset :: forall env. HasConfig env => Bool -> RIO env ()
reset Bool
keepHome = do
  Path Abs Dir
projectRoot <- 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 :: * -> *).
(HasConfig env, MonadReader env m) =>
Path Abs Dir -> m (Path Abs Dir)
projectDockerSandboxDir Path Abs Dir
projectRoot
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> IO ()
removeDirectoryContents
            Path Abs Dir
dockerSandboxDir
            [Path Rel Dir
homeDirName | Bool
keepHome]
            [])

-- | The Docker container "entrypoint": special actions performed when first

-- entering a container, such as switching the UID/GID to the "outside-Docker"

-- user's.

entrypoint :: (HasProcessContext env, HasLogFunc env)
           => Config
           -> DockerEntrypoint
           -> RIO env ()
entrypoint :: forall env.
(HasProcessContext env, HasLogFunc env) =>
Config -> DockerEntrypoint -> RIO env ()
entrypoint config :: Config
config@Config{} DockerEntrypoint{Maybe DockerUser
deUser :: DockerEntrypoint -> Maybe DockerUser
deUser :: 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
    -- Only run the entrypoint once

    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
Lens' env ProcessContext
processContextL
      Path Abs Dir
homeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a. IO a -> RIO env a
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"
      -- Get the UserEntry for the 'stack' user in the image, if it exists

      Either () UserEntry
estackUserEntry0 <- IO (Either () UserEntry) -> RIO env (Either () UserEntry)
forall a. IO a -> RIO env a
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
      -- Switch UID/GID if needed, and update user's home directory

      case Maybe DockerUser
deUser of
        Maybe DockerUser
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just (DockerUser UserID
0 GroupID
_ [GroupID]
_ FileMode
_) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right UserEntry
ue -> do
          -- If the 'stack' user exists in the image, copy any build plans and

          -- package indices from its original home directory to the host's

          -- Stack root, to avoid needing to download them

          Path Abs Dir
origStackHomeDir <- IO (Path Abs Dir) -> RIO env (Path Abs Dir)
forall a. IO a -> RIO env a
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)
Lens' Config (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 a. a -> RIO env a
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]
FileMode
GroupID
UserID
duUid :: DockerUser -> UserID
duGid :: DockerUser -> GroupID
duGroups :: DockerUser -> [GroupID]
duUmask :: DockerUser -> FileMode
duUid :: UserID
duGid :: GroupID
duGroups :: [GroupID]
duUmask :: FileMode
..} = do
    case Either a b
estackUserEntry of
      Left a
_ -> do
        -- If no 'stack' user in image, create one with correct UID/GID and home

        -- directory

        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
        -- If there is already a 'stack' user in the image, adjust its UID/GID

        -- and home directory

        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 ->
      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]
    -- 'setuid' to the wanted UID and GID

    IO () -> RIO env ()
forall a. IO a -> RIO env a
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
      [GroupID] -> IO ()
handleSetGroups [GroupID]
duGroups
      UserID -> IO ()
User.setUserID UserID
duUid
      FileMode
_ <- FileMode -> IO FileMode
Files.setFileCreationMask FileMode
duUmask
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  stackUserName :: FilePath
stackUserName = FilePath
"stack" :: String

-- | MVar used to ensure the Docker entrypoint is performed exactly once

entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar :: MVar Bool
entrypointMVar = 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)

-- | Remove the contents of a directory, without removing the directory itself.

-- This is used instead of 'FS.removeTree' to clear bind-mounted directories,

-- since removing the root of the bind-mount won't work.

removeDirectoryContents ::
     Path Abs Dir -- ^ Directory to remove contents of

  -> [Path Rel Dir] -- ^ Top-level directory names to exclude from removal

  -> [Path Rel File] -- ^ Top-level file names to exclude from removal

  -> IO ()
removeDirectoryContents :: Path Abs Dir -> [Path Rel Dir] -> [Path Rel File] -> IO ()
removeDirectoryContents Path Abs Dir
path [Path Rel Dir]
excludeDirs [Path Rel File]
excludeFiles = do
  Bool
isRootDir <- 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 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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))

-- | Produce a strict 'S.ByteString' from the stdout of a process. Throws a

-- 'ReadProcessException' exception if the process fails.

--

-- The stderr output is passed straight through, which is desirable for some

-- cases e.g. docker pull, in which docker uses stderr for progress output.

--

-- Use 'readProcess_' directly to customize this.

readDockerProcess ::
     (HasProcessContext env, HasLogFunc env)
  => [String] -> RIO env BS.ByteString
readDockerProcess :: forall env.
(HasProcessContext env, HasLogFunc env) =>
[FilePath] -> RIO env ByteString
readDockerProcess [FilePath]
args = ByteString -> ByteString
BL.toStrict (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_

-- | Name of home directory within docker sandbox.

homeDirName :: Path Rel Dir
homeDirName :: Path Rel Dir
homeDirName = Path Rel Dir
relDirUnderHome

-- | Directory where 'stack' executable is bind-mounted in Docker container

-- This refers to a path in the Linux *container*, and so should remain a

-- 'FilePath' (not 'Path Abs Dir') so that it works when the host runs Windows.

hostBinDir :: FilePath
hostBinDir :: FilePath
hostBinDir = FilePath
"/opt/host/bin"

-- | Convenience function to decode ByteString to String.

decodeUtf8 :: BS.ByteString -> String
decodeUtf8 :: ByteString -> FilePath
decodeUtf8 ByteString
bs = Text -> FilePath
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
bs)

-- | Fail with friendly error if project root not set.

getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)
getProjectRoot :: forall env. HasConfig env => RIO env (Path Abs Dir)
getProjectRoot = do
  Maybe (Path Abs Dir)
mroot <- 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
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 (DockerException -> RIO env (Path Abs Dir)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DockerException
CannotDetermineProjectRootException) Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs Dir)
mroot

-- | Environment variable that contained the old sandbox ID.

-- | Use of this variable is deprecated, and only used to detect old images.

oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar :: FilePath
oldSandboxIdEnvVar = FilePath
"DOCKER_SANDBOX_ID"

-- | Parsed result of @docker inspect@.

data Inspect = Inspect
  { Inspect -> ImageConfig
iiConfig      :: ImageConfig
  , Inspect -> UTCTime
iiCreated     :: UTCTime
  , Inspect -> Text
iiId          :: Text
  , Inspect -> Maybe Integer
iiVirtualSize :: Maybe Integer
  }
  deriving Int -> Inspect -> FilePath -> FilePath
[Inspect] -> FilePath -> FilePath
Inspect -> FilePath
(Int -> Inspect -> FilePath -> FilePath)
-> (Inspect -> FilePath)
-> ([Inspect] -> FilePath -> FilePath)
-> Show Inspect
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> Inspect -> FilePath -> FilePath
showsPrec :: Int -> Inspect -> FilePath -> FilePath
$cshow :: Inspect -> FilePath
show :: Inspect -> FilePath
$cshowList :: [Inspect] -> FilePath -> FilePath
showList :: [Inspect] -> FilePath -> FilePath
Show

-- | Parse @docker inspect@ output.

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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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"

-- | Parsed @Config@ section of @docker inspect@ output.

data ImageConfig = ImageConfig
  { ImageConfig -> [FilePath]
icEnv :: [String]
  , ImageConfig -> [FilePath]
icEntrypoint :: [String]
  }
  deriving Int -> ImageConfig -> FilePath -> FilePath
[ImageConfig] -> FilePath -> FilePath
ImageConfig -> FilePath
(Int -> ImageConfig -> FilePath -> FilePath)
-> (ImageConfig -> FilePath)
-> ([ImageConfig] -> FilePath -> FilePath)
-> Show ImageConfig
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> ImageConfig -> FilePath -> FilePath
showsPrec :: Int -> ImageConfig -> FilePath -> FilePath
$cshow :: ImageConfig -> FilePath
show :: ImageConfig -> FilePath
$cshowList :: [ImageConfig] -> FilePath -> FilePath
showList :: [ImageConfig] -> FilePath -> FilePath
Show

-- | Parse @Config@ section of @docker inspect@ output.

instance FromJSON ImageConfig where
  parseJSON :: Value -> Parser ImageConfig
parseJSON Value
v = do
    Object
o <- 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 a b. (a -> b) -> Parser a -> Parser b
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 a b. Parser (a -> b) -> Parser a -> Parser b
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 a b. (a -> b) -> Parser a -> Parser b
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
.!= []