Build Docker entrypoint into Stack (#531)

ChangeLog.md

@@ -5,6 +5,8 @@ Major changes:
 * GHCJS can now be used with stackage snapshots via the new `compiler` field.
 * Windows installers are now available:
   [download them here](https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md#windows) [#613](https://github.com/commercialhaskell/stack/issues/613)
+* Docker integration works with non-FPComplete generated images
+  [#531](https://github.com/commercialhaskell/stack/issues/531)
 
 Other enhancements:
 

src/Stack/BuildPlan.hs

@@ -469,7 +469,7 @@ loadBuildPlan name = do
     env <- ask
     let stackage = getStackRoot env
     file' <- parseRelFile $ T.unpack file
-    let fp = stackage </> $(mkRelDir "build-plan") </> file'
+    let fp = buildPlanDir stackage </> file'
     $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp)
     eres <- liftIO $ decodeFileEither $ toFilePath fp
     case eres of

src/Stack/Constants.hs

@@ -6,6 +6,7 @@
 module Stack.Constants
     (builtConfigFileFromDir
     ,builtFileFromDir
+    ,buildPlanDir
     ,configuredFileFromDir
     ,defaultShakeThreads
     ,distDirFromDir
@@ -370,3 +371,8 @@ defaultGlobalConfigPathDeprecated = parseAbsFile "/etc/stack/config"
 -- Note that this will be @Nothing@ on Windows, which is by design.
 defaultGlobalConfigPath :: Maybe (Path Abs File)
 defaultGlobalConfigPath = parseAbsFile "/etc/stack/config.yaml"
+
+-- | Path where build plans are stored.
+buildPlanDir :: Path Abs Dir -- ^ Stack root
+             -> Path Abs Dir
+buildPlanDir = (</> $(mkRelDir "build-plan"))

src/Stack/Options.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings,RecordWildCards #-}
 
 module Stack.Options
     (Command(..)
@@ -533,10 +533,8 @@ execOptsExtraParser = eoPlainParser <|>
 globalOptsParser :: Bool -> Parser GlobalOptsMonoid
 globalOptsParser hide0 =
     GlobalOptsMonoid <$>
-    optional (strOption (long Docker.reExecArgName <>
-                         hidden <>
-                         internal <>
-                         hide)) <*>
+    optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*>
+    optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*>
     logLevelOptsParser hide0 <*>
     configOptsParser hide0 <*>
     optional (abstractResolverOptsParser hide0) <*>
@@ -554,14 +552,15 @@ globalOptsParser hide0 =
 
 -- | Create GlobalOpts from GlobalOptsMonoid.
 globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts
-globalOptsFromMonoid defaultTerminal gm = GlobalOpts
-    { globalReExecVersion = globalMonoidReExecVersion gm
-    , globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel gm)
-    , globalConfigMonoid = globalMonoidConfigMonoid gm
-    , globalResolver = globalMonoidResolver gm
-    , globalCompiler = globalMonoidCompiler gm
-    , globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal gm)
-    , globalStackYaml = globalMonoidStackYaml gm }
+globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts
+    { globalReExecVersion = globalMonoidReExecVersion
+    , globalDockerEntrypoint = globalMonoidDockerEntrypoint
+    , globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel)
+    , globalConfigMonoid = globalMonoidConfigMonoid
+    , globalResolver = globalMonoidResolver
+    , globalCompiler = globalMonoidCompiler
+    , globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal)
+    , globalStackYaml = globalMonoidStackYaml }
 
 initOptsParser :: Parser InitOpts
 initOptsParser =

src/Stack/Types/Config.hs

@@ -115,6 +115,8 @@ module Stack.Types.Config
   ,VersionedDownloadInfo(..)
   ,SetupInfo(..)
   ,SetupInfoLocation(..)
+  -- ** Docker entrypoint
+  ,DockerEntrypoint(..)
   ) where
 
 import           Control.Applicative
@@ -163,6 +165,7 @@ import           Stack.Types.PackageIdentifier
 import           Stack.Types.PackageIndex
 import           Stack.Types.PackageName
 import           Stack.Types.Version
+import           System.PosixCompat.Types (UserID, GroupID)
 import           System.Process.Read (EnvOverride)
 #ifdef mingw32_HOST_OS
 import qualified Crypto.Hash.SHA1 as SHA1
@@ -373,6 +376,8 @@ data EvalOpts = EvalOpts
 -- | Parsed global command-line options.
 data GlobalOpts = GlobalOpts
     { globalReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
+    , globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
+      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
     , globalLogLevel     :: !LogLevel -- ^ Log level
     , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
     , globalResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override
@@ -384,6 +389,8 @@ data GlobalOpts = GlobalOpts
 -- | Parsed global command-line options monoid.
 data GlobalOptsMonoid = GlobalOptsMonoid
     { globalMonoidReExecVersion :: !(Maybe String) -- ^ Expected re-exec in container version
+    , globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint)
+      -- ^ Data used when stack is acting as a Docker entrypoint (internal use only)
     , globalMonoidLogLevel     :: !(Maybe LogLevel) -- ^ Log level
     , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
     , globalMonoidResolver     :: !(Maybe AbstractResolver) -- ^ Resolver override
@@ -393,9 +400,11 @@ data GlobalOptsMonoid = GlobalOptsMonoid
     } deriving (Show)
 
 instance Monoid GlobalOptsMonoid where
-    mempty = GlobalOptsMonoid Nothing Nothing mempty Nothing Nothing Nothing Nothing
+    mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing
     mappend l r = GlobalOptsMonoid
         { globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r
+        , globalMonoidDockerEntrypoint =
+            globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r
         , globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r
         , globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r
         , globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r
@@ -1513,3 +1522,9 @@ explicitSetupDeps name = do
                 case Map.lookup Nothing m of
                     Just b -> b
                     Nothing -> False -- default value
+
+-- | Data passed into Docker container for the Docker entrypoint's use
+data DockerEntrypoint = DockerEntrypoint
+    { deUidGid :: !(Maybe (UserID, GroupID))
+      -- ^ UID/GID of host user, if we wish to perform UID/GID switch in container
+    } deriving (Read,Show)

src/Stack/Types/Docker.hs

@@ -299,3 +299,7 @@ dockerSetUserArgName = "set-user"
 -- | Docker @require-version@ argument name
 dockerRequireDockerVersionArgName :: Text
 dockerRequireDockerVersionArgName = "require-docker-version"
+
+-- | Argument name used to pass docker entrypoint data (only used internally)
+dockerEntrypointArgName :: String
+dockerEntrypointArgName = "internal-docker-entrypoint"

src/main/Main.hs

@@ -855,9 +855,8 @@ execCmd ExecOpts {..} go@GlobalOpts{..} =
             (manager,lc) <- liftIO $ loadConfigWithOpts go
             withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk ->
              runStackTGlobal manager (lcConfig lc) go $
-                Docker.execWithOptionalContainer
+                Docker.reexecWithOptionalContainer
                     (lcProjectRoot lc)
-                    (\_ _ -> return (cmd, args, [], []))
                     -- Unlock before transferring control away, whether using docker or not:
                     (Just $ munlockFile lk)
                     (runStackTGlobal manager (lcConfig lc) go $
@@ -999,10 +998,15 @@ loadConfigWithOpts go@GlobalOpts{..} = do
             Just fp -> do
                 path <- canonicalizePath fp >>= parseAbsFile
                 return $ Just path
-    lc <- runStackLoggingTGlobal
-              manager
-              go
-              (loadConfig globalConfigMonoid mstackYaml)
+    lc <- runStackLoggingTGlobal manager go $ do
+        lc <- loadConfig globalConfigMonoid mstackYaml
+        -- If we have been relaunched in a Docker container, perform in-container initialization
+        -- (switch UID, etc.).  We do this after first loading the configuration since it must
+        -- happen ASAP but needs a configuration.
+        case globalDockerEntrypoint of
+            Just de -> Docker.entrypoint (lcConfig lc) de
+            Nothing -> return ()
+        return lc
     return (manager,lc)
 
 -- | Project initialization