Docker: check host's stack compatibility by attempting to run in cont…

…ainer and caching the result (#974)

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

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]

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 =

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

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

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