Download or override location of stack executable to re-run in Docker…

… container #974

ChangeLog.md

@@ -27,6 +27,7 @@ Other enhancements:
 * New experimental `stack query` command [#1087](https://github.com/commercialhaskell/stack/issues/1087)
 * By default, stack no longer rebuilds a package due to GHC options changes. This behavior can be tweaked with the `rebuild-ghc-options` setting. [#1089](https://github.com/commercialhaskell/stack/issues/1089)
 * By default, ghc-options are applied to all local packages, not just targets. This behavior can be tweaked with the `apply-ghc-options` setting. [#1089](https://github.com/commercialhaskell/stack/issues/1089)
+* Download or override location of stack executable to re-run in Docker container [#974](https://github.com/commercialhaskell/stack/issues/974)
 
 Bug fixes:
 

doc/docker_integration.md

@@ -184,6 +184,19 @@ otherwise noted.
       # all users share a single database.
       database-path: "~/.stack/docker.db"
 
+      # Location of a Docker container-compatible 'stack' executable with the
+      # matching version. This executable must be built on linux-x86_64 and
+      # statically linked.
+      # Valid values are:
+      #   host: use the host's executable.  This is the default when the host's
+      #     executable is known to work (e.g., from official linux-x86_64 bindist)
+      #   download: download a compatible executable matching the host's version.
+      #     This is the default when the host's executable is not known to work
+      #   image: use the 'stack' executable baked into the image.  The version
+      #     must match the host's version
+      #   /path/to/stack: path on the host's local filesystem
+      stack-exe: host
+
 Image Repositories
 -------------------------------------------------------------------------------
 
@@ -424,4 +437,4 @@ This does require the private registry to be available over plaintext HTTP.
 
 See
 [Docker daemon insecure registries documentation](https://docs.docker.com/reference/commandline/cli/#insecure-registries)
-for details.
+for details.

src/Stack/Config.hs

@@ -27,6 +27,7 @@ module Stack.Config
   ,packagesParser
   ,resolvePackageEntry
   ,getImplicitGlobalProjectDir
+  ,getIsGMP4
   ) where
 
 import qualified Codec.Archive.Tar as Tar
@@ -66,7 +67,7 @@ import qualified Paths_stack as Meta
 import           Safe (headMay)
 import           Stack.BuildPlan
 import           Stack.Constants
-import qualified Stack.Docker as Docker
+import           Stack.Config.Docker
 import qualified Stack.Image as Image
 import           Stack.Init
 import           Stack.Types
@@ -100,8 +101,7 @@ configFromConfigMonoid
     -> ConfigMonoid
     -> m Config
 configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoid@ConfigMonoid{..} = do
-     let configDocker = Docker.dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts
-         configConnectionCount = fromMaybe 8 configMonoidConnectionCount
+     let configConnectionCount = fromMaybe 8 configMonoidConnectionCount
          configHideTHLoading = fromMaybe True configMonoidHideTHLoading
          configLatestSnapshotUrl = fromMaybe
             "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json"
@@ -145,6 +145,8 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
 
          configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
 
+     configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts
+
      rawEnv <- liftIO getEnvironment
      origEnv <- mkEnvOverride configPlatform
               $ augmentPathMap (map toFilePath configMonoidExtraPath)
@@ -153,15 +155,15 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
      let configEnvOverride _ = return origEnv
 
      platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform
-     configLocalPrograms <-
+     configLocalProgramsBase <-
          case configPlatform of
              Platform _ Windows -> do
                  progsDir <- getWindowsProgsDir configStackRoot origEnv
-                 return $ progsDir </> $(mkRelDir stackProgName) </> platformOnlyDir
+                 return $ progsDir </> $(mkRelDir stackProgName)
              _ ->
                  return $
-                 configStackRoot </> $(mkRelDir "programs") </>
-                 platformOnlyDir
+                 configStackRoot </> $(mkRelDir "programs")
+     let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir
 
      configLocalBin <-
          case configMonoidLocalBinPath of
@@ -197,20 +199,25 @@ getDefaultGHCVariant
     :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
     => EnvOverride -> Platform -> m GHCVariant
 getDefaultGHCVariant menv (Platform _ Linux) = do
+    isGMP4 <- getIsGMP4 menv
+    return (if isGMP4 then GHCGMP4 else GHCStandard)
+getDefaultGHCVariant _ _ = return GHCStandard
+
+-- Determine whether 'stack' is linked with libgmp4 (libgmp.so.3)
+getIsGMP4
+    :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
+    => EnvOverride -> m Bool
+getIsGMP4 menv = do
     executablePath <- liftIO getExecutablePath
     elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]
     return $
         case elddOut of
-            Left _ -> GHCStandard
-            Right lddOut ->
-                if hasLineWithFirstWord "libgmp.so.3" lddOut
-                    then GHCGMP4
-                    else GHCStandard
+            Left _ -> False
+            Right lddOut -> hasLineWithFirstWord "libgmp.so.3" lddOut
   where
     hasLineWithFirstWord w =
         elem (Just w) .
         map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode
-getDefaultGHCVariant _ _ = return GHCStandard
 
 -- | Get the directory on Windows where we should install extra programs. For
 -- more information, see discussion at:

src/Stack/Config/Docker.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE CPP, RecordWildCards, TemplateHaskell #-}
+
+-- | Docker configuration
+module Stack.Config.Docker where
+
+import Control.Exception.Lifted
+import Control.Monad.Catch (throwM, MonadThrow)
+import Data.List (find)
+import Data.Maybe
+import qualified Data.Text as T
+import Path
+import Stack.Types
+
+-- | Interprets DockerOptsMonoid options.
+dockerOptsFromMonoid
+    :: MonadThrow m
+    => Maybe Project -> Path Abs Dir -> DockerOptsMonoid -> m DockerOpts
+dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = do
+    let dockerEnable =
+            fromMaybe (fromMaybe False dockerMonoidExists) dockerMonoidEnable
+        dockerImage =
+            let defaultTag =
+                    case mproject of
+                        Nothing -> ""
+                        Just proj ->
+                            case projectResolver proj of
+                                ResolverSnapshot n@(LTS _ _) ->
+                                    ":" ++ T.unpack (renderSnapName n)
+                                _ ->
+                                    throwM
+                                        (ResolverNotSupportedException $
+                                         show $ projectResolver proj)
+            in case dockerMonoidRepoOrImage of
+                   Nothing -> "fpco/stack-build" ++ defaultTag
+                   Just (DockerMonoidImage image) -> image
+                   Just (DockerMonoidRepo repo) ->
+                       case find (`elem` (":@" :: String)) repo of
+                           Just _    -- Repo already specified a tag or digest, so don't append default
+                            ->
+                               repo
+                           Nothing -> repo ++ defaultTag
+        dockerRegistryLogin =
+            fromMaybe
+                (isJust (emptyToNothing dockerMonoidRegistryUsername))
+                dockerMonoidRegistryLogin
+        dockerRegistryUsername = emptyToNothing dockerMonoidRegistryUsername
+        dockerRegistryPassword = emptyToNothing dockerMonoidRegistryPassword
+        dockerAutoPull = fromMaybe False dockerMonoidAutoPull
+        dockerDetach = fromMaybe False dockerMonoidDetach
+        dockerPersist = fromMaybe False dockerMonoidPersist
+        dockerContainerName = emptyToNothing dockerMonoidContainerName
+        dockerRunArgs = dockerMonoidRunArgs
+        dockerMount = dockerMonoidMount
+        dockerEnv = dockerMonoidEnv
+    dockerDatabasePath <-
+        case dockerMonoidDatabasePath of
+            Nothing -> return $ stackRoot </> $(mkRelFile "docker.db")
+            Just fp ->
+                case parseAbsFile fp of
+                    Left e -> throwM (InvalidDatabasePathException e)
+                    Right p -> return p
+    dockerStackExe <-
+        case dockerMonoidStackExe of
+            Just e -> parseDockerStackExe e
+#ifdef MOUNT_IN_DOCKER
+            Nothing -> return DockerStackExeHost
+#else
+            Nothing -> return DockerStackExeDownload
+#endif
+    return DockerOpts{..}
+  where emptyToNothing Nothing = Nothing
+        emptyToNothing (Just s) | null s = Nothing
+                                | otherwise = Just s
+
+-- | Exceptions thrown by Stack.Docker.Config.
+data StackDockerConfigException
+    = ResolverNotSupportedException String
+      -- ^ Only LTS resolvers are supported for default image tag.
+    | InvalidDatabasePathException SomeException
+      -- ^ Invalid global database path.
+
+-- | Exception instance for StackDockerConfigException.
+instance Exception StackDockerConfigException
+
+-- | Show instance for StackDockerConfigException.
+instance Show StackDockerConfigException where
+    show (ResolverNotSupportedException resolver) =
+        concat
+            [ "Resolver not supported for Docker images:\n    "
+            , resolver
+            , "\nUse an LTS resolver, or set the '"
+            , T.unpack dockerImageArgName
+            , "' explicitly, in your configuration file."]
+    show (InvalidDatabasePathException ex) =
+        concat ["Invalid database path: ", show ex]