From 5b39e5fcf9c63f1ccd240fa01a4af40ec14bc4c7 Mon Sep 17 00:00:00 2001 From: Emanuel Borsboom Date: Fri, 9 Oct 2015 13:25:18 -0700 Subject: [PATCH] Docker: check host's stack compatibility by attempting to run in container and caching the result (#974) --- src/Stack/Config/Docker.hs | 8 +-- src/Stack/Docker.hs | 119 +++++++++++++++++++++++------------ src/Stack/Docker/GlobalDB.hs | 26 +++++++- src/Stack/Types/Docker.hs | 2 +- src/main/Main.hs | 2 +- stack.cabal | 7 --- 6 files changed, 109 insertions(+), 55 deletions(-) diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index 4c1d1b1d31..9cd6282fba 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -63,12 +63,8 @@ dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = do Right p -> return p dockerStackExe <- case dockerMonoidStackExe of - Just e -> parseDockerStackExe e -#ifdef MOUNT_IN_DOCKER - Nothing -> return DockerStackExeHost -#else - Nothing -> return DockerStackExeDownload -#endif + Just e -> Just <$> parseDockerStackExe e + Nothing -> return Nothing return DockerOpts{..} where emptyToNothing Nothing = Nothing emptyToNothing (Just s) | null s = Nothing diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 812384a4c8..672919213d 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -32,6 +32,7 @@ import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii,isDigit) +import Data.Conduit.List (sinkNull) import Data.List (dropWhileEnd,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) import Data.List.Extra (trim) import Data.Map.Strict (Map) @@ -56,7 +57,7 @@ import Stack.Docker.GlobalDB import Stack.Types import Stack.Types.Internal import Stack.Setup (ensureDockerStackExe) -import System.Directory (canonicalizePath) +import System.Directory (canonicalizePath, getModificationTime) import System.Environment (lookupEnv,getProgName, getArgs,getExecutablePath) import System.Exit (exitSuccess, exitWith) import System.FilePath (dropTrailingPathSeparator,takeBaseName) @@ -88,39 +89,88 @@ reexecWithOptionalContainer -> Maybe (m ()) -> m () reexecWithOptionalContainer mprojectRoot = - execWithOptionalContainer mprojectRoot getCmdArgs + execWithOptionalContainer mprojectRoot getCmdArgs where - getCmdArgs = do + getCmdArgs envOverride imageInfo = do config <- asks getConfig args <- fmap (("--" ++ reExecArgName ++ "=" ++ showVersion Meta.version) :) (liftIO getArgs) case dockerStackExe (configDocker config) of - DockerStackExeHost + Just DockerStackExeHost | configPlatform config == dockerContainerPlatform -> fmap (cmdArgs args) (liftIO getExecutablePath) - | otherwise -> - throwM UnsupportedStackExeHostPlatformException - DockerStackExeImage -> do + | otherwise -> throwM UnsupportedStackExeHostPlatformException + Just DockerStackExeImage -> do progName <- liftIO getProgName - return (takeBaseName progName, args, [], id) - DockerStackExePath path -> - fmap (cmdArgs args) (liftIO $ canonicalizePath (toFilePath path)) - DockerStackExeDownload -> - fmap (cmdArgs args . toFilePath) (ensureDockerStackExe dockerContainerPlatform) + return (takeBaseName progName, args, [], []) + Just (DockerStackExePath path) -> + fmap + (cmdArgs args) + (liftIO $ canonicalizePath (toFilePath path)) + Just DockerStackExeDownload -> exeDownload args + Nothing | configPlatform config == dockerContainerPlatform -> do + (exePath,exeTimestamp,misCompatible) <- + liftIO $ + do exePath <- liftIO getExecutablePath + exeTimestamp <- liftIO (getModificationTime exePath) + isKnown <- + liftIO $ + getDockerImageExe + config + (iiId imageInfo) + exePath + exeTimestamp + return (exePath, exeTimestamp, isKnown) + case misCompatible of + Just True -> do + return (cmdArgs args exePath) + Just False -> do + exeDownload args + Nothing -> do + e <- + try $ + sinkProcessStderrStdout + Nothing + envOverride + "docker" + [ "run" + , "-v" + , exePath ++ ":" ++ "/tmp/stack" + , iiId imageInfo + , "/tmp/stack" + , "--version" ] + sinkNull + sinkNull + case e of + Left (ProcessExitedUnsuccessfully _ _) -> do + liftIO $ + setDockerImageExe + config + (iiId imageInfo) + exePath + exeTimestamp + False + exeDownload args + Right _ -> do + liftIO $ + setDockerImageExe + config + (iiId imageInfo) + exePath + exeTimestamp + True + return (cmdArgs args exePath) + Nothing | otherwise -> do + exeDownload args + exeDownload args = + fmap + (cmdArgs args . toFilePath) + (ensureDockerStackExe dockerContainerPlatform) cmdArgs args exePath = let mountPath = concat ["/opt/host/bin/", takeBaseName exePath] - in ( mountPath - , args - , [] - , \c -> - c - { configDocker = (configDocker c) - { dockerMount = Mount exePath mountPath : - dockerMount (configDocker c) - } - }) + in (mountPath, args, [], [Mount exePath mountPath]) -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action. @@ -129,7 +179,7 @@ reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer :: M env m => Maybe (Path Abs Dir) - -> m (FilePath,[String],[(String,String)],Config -> Config) + -> (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) -> Maybe (m ()) -> IO () -> Maybe (m ()) @@ -150,15 +200,11 @@ execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease fromMaybeAction mafter liftIO exitSuccess | otherwise -> - do (cmd_,args,envVars,modConfig) <- getCmdArgs - fromMaybeAction mrelease + do fromMaybeAction mrelease runContainerAndExit - modConfig + getCmdArgs mprojectRoot (fromMaybeAction mbefore) - cmd_ - args - envVars (fromMaybeAction mafter) where fromMaybeAction Nothing = return () @@ -178,22 +224,16 @@ getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar) -- | Run a command in a new Docker container, then exit the process. runContainerAndExit :: M env m - => (Config -> Config) + => (EnvOverride -> Inspect -> m (FilePath,[String],[(String,String)],[Mount])) -> Maybe (Path Abs Dir) -> m () - -> FilePath - -> [String] - -> [(String, String)] -> m () -> m () -runContainerAndExit modConfig +runContainerAndExit getCmdArgs mprojectRoot before - cmnd - args - envVars after = - do config <- fmap modConfig (asks getConfig) + do config <- asks getConfig let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride @@ -232,6 +272,7 @@ runContainerAndExit modConfig Just ii2 -> return ii2 Nothing -> throwM (InspectFailedException image) | otherwise -> throwM (NotPulledException image) + (cmnd,args,envVars,extraMount) <- getCmdArgs envOverride imageInfo let imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo)) sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) sandboxIDDir <- parseRelDir (sandboxID ++ "/") @@ -276,7 +317,7 @@ runContainerAndExit modConfig ,userEnvVars ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars ,concatMap sandboxSubdirArg sandboxSubdirs - ,concatMap mountArg (dockerMount docker) + ,concatMap mountArg (extraMount ++ dockerMount docker) ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker) ,case dockerContainerName docker of Just name -> ["--name=" ++ name] diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs index 25b45f0af6..28091df73d 100644 --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -9,7 +9,10 @@ module Stack.Docker.GlobalDB ,getDockerImagesLastUsed ,pruneDockerImagesLastUsed ,DockerImageLastUsed - ,DockerImageProjectId) + ,DockerImageProjectId + ,getDockerImageExe + ,setDockerImageExe + ,DockerImageExeId) where import Control.Exception (IOException,catch,throwIO) @@ -36,6 +39,13 @@ DockerImageProject lastUsedTime UTCTime DockerImageProjectPathKey imageHash projectPath deriving Show +DockerImageExe + imageHash String + exePath FilePath + exeTimestamp UTCTime + compatible Bool + DockerImageExeUnique imageHash exePath exeTimestamp + deriving Show |] -- | Update last used time and project for a Docker image hash. @@ -71,6 +81,20 @@ pruneDockerImagesLastUsed config existingHashes = then return () else delete k) +-- | Get the record of whether an executable is compatible with a Docker image +getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool) +getDockerImageExe config imageId exePath exeTimestamp = + withGlobalDB config $ do + mentity <- getBy (DockerImageExeUnique imageId exePath exeTimestamp) + return (fmap (dockerImageExeCompatible . entityVal) mentity) + +-- | Seet the record of whether an executable is compatible with a Docker image +setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO () +setDockerImageExe config imageId exePath exeTimestamp compatible = + withGlobalDB config $ + do _ <- upsert (DockerImageExe imageId exePath exeTimestamp compatible) [] + return () + -- | Run an action with the global database. This performs any needed migrations as well. withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a withGlobalDB config action = diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index d11629c983..e97a4c08e9 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -42,7 +42,7 @@ data DockerOpts = DockerOpts -- ^ Environment variables to set in the container. ,dockerDatabasePath :: !(Path Abs File) -- ^ Location of image usage database. - ,dockerStackExe :: !DockerStackExe + ,dockerStackExe :: !(Maybe DockerStackExe) -- ^ Location of container-compatible stack executable ,dockerSetUser :: !(Maybe Bool) -- ^ Set in-container user to match host's diff --git a/src/main/Main.hs b/src/main/Main.hs index 561a7e81f4..6da4a5ec9c 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -796,7 +796,7 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = do runStackTGlobal manager (lcConfig lc) go $ Docker.execWithOptionalContainer (lcProjectRoot lc) - (return (cmd, args, [], id)) + (\_ _ -> return (cmd, args, [], [])) -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) (runStackTGlobal manager (lcConfig lc) go $ do diff --git a/stack.cabal b/stack.cabal index 3a7cb2b731..5d7ba93006 100644 --- a/stack.cabal +++ b/stack.cabal @@ -30,11 +30,6 @@ flag integration-tests default: False description: Run the integration test suite -flag mount-in-docker - manual: True - default: False - description: Bind-mount generated executable directly into created Docker containers (set when known to work, e.g. for linux-x86_64 w/ libgmp10) - library hs-source-dirs: src/ ghc-options: -Wall @@ -188,8 +183,6 @@ library build-depends: Win32 else build-depends: unix >= 2.7.0.1 - if flag(mount-in-docker) - cpp-options: -DMOUNT_IN_DOCKER default-language: Haskell2010 executable stack