{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# 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 Data.Version (showVersion)
import Distribution.Version (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 (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 (stderr,stdin)
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 RIO.Process
#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 docker imageInfo isRemoteDocker = do
config <- view configL
deUser <-
if fromMaybe (not isRemoteDocker) (dockerSetUser docker)
then liftIO $ do
duUid <- User.getEffectiveUserID
duGid <- User.getEffectiveGroupID
duGroups <- nubOrd <$> User.getGroups
duUmask <- Files.setFileCreationMask 0o022
_ <- Files.setFileCreationMask duUmask
return (Just DockerUser{..})
else return Nothing
args <-
fmap
(["--" ++ reExecArgName ++ "=" ++ showVersion Meta.version
,"--" ++ dockerEntrypointArgName
,show DockerEntrypoint{..}] ++)
(liftIO getArgs)
case dockerStackExe (configDocker config) of
Just DockerStackExeHost
| configPlatform config == dockerContainerPlatform -> do
exePath <- resolveFile' =<< liftIO getExecutablePath
cmdArgs args exePath
| otherwise -> throwIO UnsupportedStackExeHostPlatformException
Just DockerStackExeImage -> do
progName <- liftIO getProgName
return (FP.takeBaseName progName, args, [], [])
Just (DockerStackExePath path) -> do
cmdArgs args path
Just DockerStackExeDownload -> exeDownload args
Nothing
| configPlatform config == dockerContainerPlatform -> do
(exePath,exeTimestamp,misCompatible) <-
do exePath <- resolveFile' =<< liftIO getExecutablePath
exeTimestamp <- getModificationTime exePath
isKnown <-
loadDockerImageExeCache
(iiId imageInfo)
exePath
exeTimestamp
return (exePath, exeTimestamp, isKnown)
case misCompatible of
Just True -> cmdArgs args exePath
Just False -> exeDownload args
Nothing -> do
e <-
try $
sinkProcessStderrStdout
"docker"
[ "run"
, "-v"
, toFilePath exePath ++ ":" ++ "/tmp/stack"
, T.unpack (iiId imageInfo)
, "/tmp/stack"
, "--version"]
sinkNull
sinkNull
let compatible =
case e of
Left ExitCodeException{} -> False
Right _ -> True
saveDockerImageExeCache
(iiId imageInfo)
exePath
exeTimestamp
compatible
if compatible
then cmdArgs args exePath
else exeDownload args
Nothing -> exeDownload args
where
exeDownload args = do
exePath <- ensureDockerStackExe dockerContainerPlatform
cmdArgs args exePath
cmdArgs args exePath = do
exeBase <- exePath -<.> ""
let mountPath = hostBinDir FP.</> toFilePath (filename exeBase)
return (mountPath, args, [], [Mount (toFilePath exePath) mountPath])
preventInContainer :: MonadIO m => m () -> m ()
preventInContainer inner =
do inContainer <- getInContainer
if inContainer
then throwIO OnlyOnHostException
else inner
runContainerAndExit :: HasConfig env => RIO env void
runContainerAndExit = do
config <- view configL
let docker = configDocker config
checkDockerVersion docker
(env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $
(,,,)
<$> getEnvironment
<*> hIsTerminalDeviceOrMinTTY stdin
<*> hIsTerminalDeviceOrMinTTY stderr
<*> getHomeDir
isStdoutTerminal <- view terminalL
let dockerHost = lookup "DOCKER_HOST" env
dockerCertPath = lookup "DOCKER_CERT_PATH" env
bamboo = lookup "bamboo_buildKey" env
jenkins = lookup "JENKINS_HOME" env
msshAuthSock = lookup "SSH_AUTH_SOCK" env
muserEnv = lookup "USER" env
isRemoteDocker = maybe False (isPrefixOf "tcp://") dockerHost
image <- either throwIO pure (dockerImage docker)
when (isRemoteDocker &&
maybe False (isInfixOf "boot2docker") dockerCertPath)
(logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
maybeImageInfo <- inspect image
imageInfo@Inspect{..} <- case maybeImageInfo of
Just ii -> return ii
Nothing
| dockerAutoPull docker ->
do pullImage docker image
mii2 <- inspect image
case mii2 of
Just ii2 -> return ii2
Nothing -> throwM (InspectFailedException image)
| otherwise -> throwM (NotPulledException image)
projectRoot <- getProjectRoot
sandboxDir <- projectDockerSandboxDir projectRoot
let ImageConfig {..} = iiConfig
imageEnvVars = map (break (== '=')) icEnv
platformVariant = show $ hashRepoName image
stackRoot = view stackRootL config
sandboxHomeDir = sandboxDir </> homeDirName
isTerm = not (dockerDetach docker) &&
isStdinTerminal &&
isStdoutTerminal &&
isStderrTerminal
keepStdinOpen = not (dockerDetach docker) &&
(isTerm || (isNothing bamboo && isNothing jenkins))
let mpath = T.pack <$> lookupImageEnv "PATH" imageEnvVars
when (isNothing mpath) $ do
logWarn "The Docker image does not set the PATH env var"
logWarn "This will likely fail, see https://github.com/commercialhaskell/stack/issues/2742"
newPathEnv <- either throwM return $ augmentPath
[ hostBinDir
, toFilePath (sandboxHomeDir </> relDirDotLocal </> relDirBin)]
mpath
(cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker
pwd <- getCurrentDir
liftIO $ mapM_ ensureDir [sandboxHomeDir, stackRoot]
let sshDir = homeDir </> sshRelDir
sshDirExists <- doesDirExist sshDir
sshSandboxDirExists <-
liftIO
(Files.fileExist
(toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir)))
when (sshDirExists && not sshSandboxDirExists)
(liftIO
(Files.createSymbolicLink
(toFilePathNoTrailingSep sshDir)
(toFilePathNoTrailingSep (sandboxHomeDir </> sshRelDir))))
let mountSuffix = maybe "" (":" ++) (dockerMountMode docker)
containerID <- withWorkingDir (toFilePath projectRoot) $ trim . decodeUtf8 <$> readDockerProcess
(concat
[["create"
,"--net=host"
,"-e",inContainerEnvVar ++ "=1"
,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant
,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
,"-e","PATH=" ++ T.unpack newPathEnv
,"-e","PWD=" ++ toFilePathNoTrailingSep pwd
,"-v",toFilePathNoTrailingSep homeDir ++ ":" ++ toFilePathNoTrailingSep homeDir ++ mountSuffix
,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot ++ mountSuffix
,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot ++ mountSuffix
,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir ++ mountSuffix
,"-w",toFilePathNoTrailingSep pwd]
,case muserEnv of
Nothing -> []
Just userEnv -> ["-e","USER=" ++ userEnv]
,case msshAuthSock of
Nothing -> []
Just sshAuthSock ->
["-e","SSH_AUTH_SOCK=" ++ sshAuthSock
,"-v",sshAuthSock ++ ":" ++ sshAuthSock]
,["--entrypoint=/usr/bin/env"
| isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&
(icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||
icEntrypoint == ["/root/entrypoint.sh"])]
,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
,concatMap (mountArg mountSuffix) (extraMount ++ dockerMount docker)
,concatMap (\nv -> ["-e", nv]) (dockerEnv docker)
,case dockerContainerName docker of
Just name -> ["--name=" ++ name]
Nothing -> []
,["-t" | isTerm]
,["-i" | keepStdinOpen]
,dockerRunArgs docker
,[image]
,[cmnd]
,args])
#ifndef WINDOWS
run <- askRunInIO
oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do
let sigHandler = run $ do
readProcessNull "docker" ["kill","--signal=" ++ show sig,containerID]
when (sig `elem` [sigTERM,sigABRT]) $ do
threadDelay 30000000
readProcessNull "docker" ["kill",containerID]
oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing
return (sig, oldHandler)
#endif
let args' = concat [["start"]
,["-a" | not (dockerDetach docker)]
,["-i" | keepStdinOpen]
,[containerID]]
e <- try (proc "docker" args' $ runProcess_ . setDelegateCtlc False)
`finally`
(do unless (dockerPersist docker || dockerDetach docker) $
readProcessNull "docker" ["rm","-f",containerID]
`catch` (\(_::ExitCodeException) -> return ())
#ifndef WINDOWS
forM_ oldHandlers $ \(sig,oldHandler) ->
liftIO $ installHandler sig oldHandler Nothing
#endif
)
case e of
Left ExitCodeException{eceExitCode} -> exitWith eceExitCode
Right () -> exitSuccess
where
hashRepoName :: String -> Hash.Digest Hash.MD5
hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
lookupImageEnv name vars =
case lookup name vars of
Just ('=':val) -> Just val
_ -> Nothing
mountArg mountSuffix (Mount host container) =
["-v",host ++ ":" ++ container ++ mountSuffix]
sshRelDir = relDirDotSsh
inspect :: (HasProcessContext env, HasLogFunc env)
=> String -> RIO env (Maybe Inspect)
inspect image =
do results <- inspects [image]
case Map.toList results of
[] -> return Nothing
[(_,i)] -> return (Just i)
_ -> throwIO (InvalidInspectOutputException "expect a single result")
inspects :: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env (Map Text Inspect)
inspects [] = return Map.empty
inspects images =
do maybeInspectOut <-
try (BL.toStrict . fst <$> proc "docker" ("inspect" : images) readProcess_)
case maybeInspectOut of
Right inspectOut ->
case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of
Left msg -> throwIO (InvalidInspectOutputException msg)
Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results))
Left ece
| any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> return Map.empty
Left e -> throwIO e
where missingImagePrefixes = ["Error: No such image", "Error: No such object:"]
pull :: HasConfig env => RIO env ()
pull =
do config <- view configL
let docker = configDocker config
checkDockerVersion docker
either throwIO (pullImage docker) (dockerImage docker)
pullImage :: (HasProcessContext env, HasLogFunc env)
=> DockerOpts -> String -> RIO env ()
pullImage docker image =
do logInfo ("Pulling image from registry: '" <> fromString image <> "'")
when (dockerRegistryLogin docker)
(do logInfo "You may need to log in."
proc
"docker"
(concat
[["login"]
,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker)
,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
,[takeWhile (/= '/') image]])
runProcess_)
ec <- proc "docker" ["pull", image] $ \pc0 -> do
let pc = setStdout (useHandleOpen stderr)
$ setStderr (useHandleOpen stderr)
$ setStdin closed
pc0
runProcess pc
case ec of
ExitSuccess -> return ()
ExitFailure _ -> throwIO (PullFailedException image)
checkDockerVersion
:: (HasProcessContext env, HasLogFunc env)
=> DockerOpts -> RIO env ()
checkDockerVersion docker =
do dockerExists <- doesExecutableExist "docker"
unless dockerExists (throwIO DockerNotInstalledException)
dockerVersionOut <- readDockerProcess ["--version"]
case words (decodeUtf8 dockerVersionOut) of
(_:_:v:_) ->
case parseVersion (stripVersion v) of
Just v'
| v' < minimumDockerVersion ->
throwIO (DockerTooOldException minimumDockerVersion v')
| v' `elem` prohibitedDockerVersions ->
throwIO (DockerVersionProhibitedException prohibitedDockerVersions v')
| not (v' `withinRange` dockerRequireDockerVersion docker) ->
throwIO (BadDockerVersionException (dockerRequireDockerVersion docker) v')
| otherwise ->
return ()
_ -> throwIO InvalidVersionOutputException
_ -> throwIO InvalidVersionOutputException
where minimumDockerVersion = mkVersion [1, 6, 0]
prohibitedDockerVersions = []
stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v)
reset :: HasConfig env => Bool -> RIO env ()
reset keepHome = do
projectRoot <- getProjectRoot
dockerSandboxDir <- projectDockerSandboxDir projectRoot
liftIO (removeDirectoryContents
dockerSandboxDir
[homeDirName | keepHome]
[])
entrypoint :: (HasProcessContext env, HasLogFunc env)
=> Config -> DockerEntrypoint -> RIO env ()
entrypoint config@Config{..} DockerEntrypoint{..} =
modifyMVar_ entrypointMVar $ \alreadyRan -> do
unless alreadyRan $ do
envOverride <- view processContextL
homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME"
estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $
User.getUserEntryForName stackUserName
case deUser of
Nothing -> return ()
Just (DockerUser 0 _ _ _) -> return ()
Just du -> withProcessContext envOverride $ updateOrCreateStackUser estackUserEntry0 homeDir du
case estackUserEntry0 of
Left _ -> return ()
Right ue -> do
origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue)
let origStackRoot = origStackHomeDir </> relDirDotStackProgName
buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot)
when buildPlanDirExists $ do
(_, buildPlans) <- listDir (buildPlanDir origStackRoot)
forM_ buildPlans $ \srcBuildPlan -> do
let destBuildPlan = buildPlanDir (view stackRootL config) </> filename srcBuildPlan
exists <- doesFileExist destBuildPlan
unless exists $ do
ensureDir (parent destBuildPlan)
copyFile srcBuildPlan destBuildPlan
return True
where
updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do
case estackUserEntry of
Left _ -> do
readProcessNull "groupadd"
["-o"
,"--gid",show duGid
,stackUserName]
readProcessNull "useradd"
["-oN"
,"--uid",show duUid
,"--gid",show duGid
,"--home",toFilePathNoTrailingSep homeDir
,stackUserName]
Right _ -> do
readProcessNull "usermod"
["-o"
,"--uid",show duUid
,"--home",toFilePathNoTrailingSep homeDir
,stackUserName]
readProcessNull "groupmod"
["-o"
,"--gid",show duGid
,stackUserName]
forM_ duGroups $ \gid -> do
readProcessNull "groupadd"
["-o"
,"--gid",show gid
,"group" ++ show gid]
liftIO $ do
User.setGroupID duGid
#ifndef WINDOWS
PosixUser.setGroups duGroups
#endif
User.setUserID duUid
_ <- Files.setFileCreationMask duUmask
return ()
stackUserName = "stack"::String
entrypointMVar :: MVar Bool
{-# NOINLINE entrypointMVar #-}
entrypointMVar = unsafePerformIO (newMVar False)
removeDirectoryContents :: Path Abs Dir
-> [Path Rel Dir]
-> [Path Rel File]
-> IO ()
removeDirectoryContents path excludeDirs excludeFiles =
do isRootDir <- doesDirExist path
when isRootDir
(do (lsd,lsf) <- listDir path
forM_ lsd
(\d -> unless (dirname d `elem` excludeDirs)
(removeDirRecur d))
forM_ lsf
(\f -> unless (filename f `elem` excludeFiles)
(removeFile f)))
readDockerProcess
:: (HasProcessContext env, HasLogFunc env)
=> [String] -> RIO env BS.ByteString
readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_
homeDirName :: Path Rel Dir
homeDirName = relDirUnderHome
hostBinDir :: FilePath
hostBinDir = "/opt/host/bin"
decodeUtf8 :: BS.ByteString -> String
decodeUtf8 bs = T.unpack (T.decodeUtf8 bs)
getProjectRoot :: HasConfig env => RIO env (Path Abs Dir)
getProjectRoot = do
mroot <- view $ configL.to configProjectRoot
maybe (throwIO CannotDetermineProjectRootException) pure mroot
oldSandboxIdEnvVar :: String
oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
data Inspect = Inspect
{iiConfig :: ImageConfig
,iiCreated :: UTCTime
,iiId :: Text
,iiVirtualSize :: Maybe Integer}
deriving (Show)
instance FromJSON Inspect where
parseJSON v =
do o <- parseJSON v
Inspect <$> o .: "Config"
<*> o .: "Created"
<*> o .: "Id"
<*> o .:? "VirtualSize"
data ImageConfig = ImageConfig
{icEnv :: [String]
,icEntrypoint :: [String]}
deriving (Show)
instance FromJSON ImageConfig where
parseJSON v =
do o <- parseJSON v
ImageConfig
<$> fmap join (o .:? "Env") .!= []
<*> fmap join (o .:? "Entrypoint") .!= []