Add 'allow-different-user' flag and configuration option #471, fix #1777

Users other than the owner of the ~/.stack directory are now prevented
from using a stack installation in order to avoid problems with file
permissions. To disable this precaution users can pass the
--allow-different-user flag or use the 'allow-different-user'
configuration option in their ~/.stack/config.yaml.

On Windows, the new flag and configuration options have no effect.

When stack is re-spawned in Docker, the ownership check is skipped
(see #1777).

This reverts commits 0a89c9c and
218e7dd.

ChangeLog.md

@@ -26,6 +26,12 @@ Other enhancements:
   work [#1358](https://github.com/commercialhaskell/stack/issues/1358)
 * Docker: strip suffix from docker --version
   [#1653](https://github.com/commercialhaskell/stack/issues/1653)
+* On each run, stack will test the stack root directory (~/.stack), and the
+  project and package work directories (.stack-work) for whether they are
+  owned by the current user and abort if they are not. This precaution can
+  be disabled with the `--allow-different-user` flag or `allow-different-user`
+  option in the global config (~/.stack/config.yaml).
+  [#471](https://github.com/commercialhaskell/stack/issues/471)
 
 Bug fixes:
 

doc/yaml_configuration.md

@@ -435,6 +435,22 @@ allow-newer: true
 Note that this also ignores lower bounds. The name "allow-newer" is chosen to
 match the commonly used cabal option.
 
+### allow-different-user
+
+(Since 1.0.1)
+
+Allow users other than the owner of the stack root directory (typically `~/.stack`)
+to use the stack installation. The default is `false`. POSIX systems only.
+
+```yaml
+allow-different-user: true
+```
+
+The intention of this option is to prevent file permission problems, for example
+as the result of a `stack` command executed under `sudo`.
+
+The option is automatically enabled when `stack` is re-spawned in a Docker process.
+
 ### templates
 
 Templates used with `stack new` have a number of parameters that affect the generated code. These can be set for all new projects you create. The result of them can be observed in the generated LICENSE and cabal files.

src/Path/Find.hs

@@ -5,7 +5,8 @@
 module Path.Find
   (findFileUp
   ,findDirUp
-  ,findFiles)
+  ,findFiles
+  ,findInParents)
   where
 
 import Control.Monad
@@ -66,3 +67,16 @@ findFiles dir p traversep =
                   then findFiles entry p traversep
                   else return [])
      return (concat (filter p files : subResults))
+
+-- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until
+-- it finds a 'Just' or reaches the root directory.
+findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)
+findInParents f path = do
+    mres <- f path
+    case mres of
+        Just res -> return (Just res)
+        Nothing -> do
+            let next = parent path
+            if next == path
+                then return Nothing
+                else findInParents f next

src/Stack/Build/Execute.hs

@@ -70,6 +70,7 @@ import           Stack.Build.Cache
 import           Stack.Build.Haddock
 import           Stack.Build.Installed
 import           Stack.Build.Source
+import           Stack.Config
 import           Stack.Constants
 import           Stack.Coverage
 import           Stack.Fetch as Fetch
@@ -769,6 +770,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
 
     withCabal package pkgDir mlogFile inner = do
         config <- asks getConfig
+
+        unless (configAllowDifferentUser config) $
+            checkOwnership (pkgDir </> configWorkDir config)
+
         let envSettings = EnvSettings
                 { esIncludeLocals = taskLocation task == Local
                 , esIncludeGhcPackagePath = False

src/Stack/Config.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -30,6 +31,8 @@ module Stack.Config
   ,getIsGMP4
   ,getSnapshots
   ,makeConcreteResolver
+  ,checkOwnership
+  ,getInContainer
   ) where
 
 import qualified Codec.Archive.Tar as Tar
@@ -40,6 +43,7 @@ import           Control.Arrow ((***))
 import           Control.Exception (assert)
 import           Control.Monad (liftM, unless, when, filterM)
 import           Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM)
+import           Control.Monad.Extra (firstJustM)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger hiding (Loc)
 import           Control.Monad.Reader (MonadReader, ask, asks, runReaderT)
@@ -49,6 +53,7 @@ import           Data.Aeson.Extended
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Lazy as L
+import           Data.Foldable (forM_)
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import           Data.Maybe
@@ -66,6 +71,7 @@ import           Network.HTTP.Download (download, downloadJSON)
 import           Options.Applicative (Parser, strOption, long, help)
 import           Path
 import           Path.Extra (toFilePathNoTrailingSep)
+import           Path.Find (findInParents)
 import           Path.IO
 import qualified Paths_stack as Meta
 import           Safe (headMay)
@@ -77,9 +83,10 @@ import qualified Stack.Image as Image
 import           Stack.PackageIndex
 import           Stack.Types
 import           Stack.Types.Internal
-import qualified System.Directory as D
 import           System.Environment
 import           System.IO
+import           System.PosixCompat.Files (fileOwner, getFileStatus)
+import           System.PosixCompat.User (getEffectiveUserID)
 import           System.Process.Read
 
 -- | If deprecated path exists, use it and print a warning.
@@ -289,6 +296,11 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c
          configAllowNewer = fromMaybe False configMonoidAllowNewer
          configDefaultTemplate = configMonoidDefaultTemplate
 
+     configAllowDifferentUser <-
+        case configMonoidAllowDifferentUser of
+            Just True -> return True
+            _ -> getInContainer
+
      return Config {..}
 
 -- | Get the default 'GHCVariant'.  On older Linux systems with libgmp4, returns 'GHCGMP4'.
@@ -365,7 +377,7 @@ loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseContro
            -- ^ Override resolver
            -> m (LoadConfig m)
 loadConfig configArgs mstackYaml mresolver = do
-    stackRoot <- determineStackRoot
+    (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership
     userConfigPath <- getDefaultUserConfigPath stackRoot
     extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml
     let extraConfigs =
@@ -387,10 +399,18 @@ loadConfig configArgs mstackYaml mresolver = do
             Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs
     unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
         (throwM (BadStackVersionException (configRequireStackVersion config)))
+
+    let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject
+    unless (configAllowDifferentUser config) $ do
+        unless userOwnsStackRoot $
+            throwM (UserDoesn'tOwnDirectory stackRoot)
+        forM_ mprojectRoot $ \dir ->
+            checkOwnership (dir </> configWorkDir config)
+
     return LoadConfig
         { lcConfig          = config
         , lcLoadBuildConfig = loadBuildConfig mproject config mresolver
-        , lcProjectRoot     = fmap (\(_, fp, _) -> parent fp) mproject
+        , lcProjectRoot     = mprojectRoot
         }
 
 -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
@@ -611,15 +631,83 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
                               throwM $ UnexpectedArchiveContents dirs files
         _ -> return dir
 
--- | Get the stack root, e.g. ~/.stack
-determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)
-determineStackRoot = do
-    env <- liftIO getEnvironment
-    case lookup stackRootEnvVar env of
-        Nothing -> getAppUserDataDir $(mkRelDir stackProgName)
-        Just x -> do
-            liftIO $ D.createDirectoryIfMissing True x
-            resolveDir' x
+-- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it.
+--
+-- On Windows, the second value is always 'True'.
+determineStackRootAndOwnership
+    :: (MonadIO m, MonadCatch m)
+    => m (Path Abs Dir, Bool)
+determineStackRootAndOwnership = do
+    stackRoot <- do
+        mstackRoot <- liftIO $ lookupEnv stackRootEnvVar
+        case mstackRoot of
+            Nothing -> getAppUserDataDir $(mkRelDir stackProgName)
+            Just x -> parseAbsDir x
+
+    (existingStackRootOrParentDir, userOwnsIt) <- do
+        mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
+        case mdirAndOwnership of
+            Just x -> return x
+            Nothing -> throwM (BadStackRootEnvVar stackRoot)
+
+    when (existingStackRootOrParentDir /= stackRoot) $
+        if userOwnsIt
+            then liftIO $ ensureDir stackRoot
+            else throwM $
+                Won'tCreateStackRootInDirectoryOwnedByDifferentUser
+                    stackRoot
+                    existingStackRootOrParentDir
+
+    stackRoot' <- canonicalizePath stackRoot
+    return (stackRoot', userOwnsIt)
+
+-- | @'checkOwnership' dir@ throws 'UserDoesn'tOwnDirectory' if @dir@
+-- isn't owned by the current user.
+--
+-- If @dir@ doesn't exist, its parent directory is checked instead.
+-- If the parent directory doesn't exist either, @'NoSuchDirectory' ('parent' dir)@
+-- is thrown.
+checkOwnership :: (MonadIO m, MonadCatch m) => Path Abs Dir -> m ()
+checkOwnership dir = do
+    mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]
+    case mdirAndOwnership of
+        Just (_, True) -> return ()
+        Just (dir', False) -> throwM (UserDoesn'tOwnDirectory dir')
+        Nothing ->
+            (throwM . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir
+
+-- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@
+-- exists and the current user owns it in the sense of 'isOwnedByUser'.
+getDirAndOwnership
+    :: (MonadIO m, MonadCatch m)
+    => Path Abs Dir
+    -> m (Maybe (Path Abs Dir, Bool))
+getDirAndOwnership dir = forgivingAbsence $ do
+    ownership <- isOwnedByUser dir
+    return (dir, ownership)
+
+-- | Check whether the current user (determined with 'getEffectiveUserId') is
+-- the owner for the given path.
+--
+-- Will always return 'True' on Windows.
+isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
+isOwnedByUser path = liftIO $ do
+    if osIsWindows
+        then return True
+        else do
+            fileStatus <- getFileStatus (toFilePath path)
+            user <- getEffectiveUserID
+            return (user == fileOwner fileStatus)
+  where
+#ifdef WINDOWS
+    osIsWindows = True
+#else
+    osIsWindows = False
+#endif
+
+-- | 'True' if we are currently running inside a Docker container.
+getInContainer :: (MonadIO m) => m Bool
+getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
 
 -- | Determine the extra config file locations which exist.
 --
@@ -665,21 +753,16 @@ getProjectConfig Nothing = do
             liftM Just $ resolveFile' fp
         Nothing -> do
             currDir <- getCurrentDir
-            search currDir
+            findInParents getStackDotYaml currDir
   where
-    search dir = do
+    getStackDotYaml dir = do
         let fp = dir </> stackDotYaml
             fp' = toFilePath fp
         $logDebug $ "Checking for project config at: " <> T.pack fp'
         exists <- doesFileExist fp
         if exists
             then return $ Just fp
-            else do
-                let dir' = parent dir
-                if dir == dir'
-                    -- fully traversed, give up
-                    then return Nothing
-                    else search dir'
+            else return Nothing
 
 -- | Find the project config file location, respecting environment variables
 -- and otherwise traversing parents. If no config is found, we supply a default

src/Stack/Constants.hs

@@ -18,6 +18,7 @@ module Stack.Constants
     ,rawGithubUrl
     ,stackDotYaml
     ,stackRootEnvVar
+    ,inContainerEnvVar
     ,userDocsDir
     ,configCacheFile
     ,configCabalMod
@@ -300,6 +301,10 @@ stackDotYaml = $(mkRelFile "stack.yaml")
 stackRootEnvVar :: String
 stackRootEnvVar = "STACK_ROOT"
 
+-- | Environment variable used to indicate stack is running in container.
+inContainerEnvVar :: String
+inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
+
 -- See https://downloads.haskell.org/~ghc/7.10.1/docs/html/libraries/ghc/src/Module.html#integerPackageKey
 wiredInPackages :: HashSet PackageName
 wiredInPackages =

src/Stack/Constants.hs-boot

@@ -0,0 +1,3 @@
+module Stack.Constants where
+
+stackRootEnvVar :: String

src/Stack/Docker.hs

@@ -59,14 +59,14 @@ import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.IO hiding (canonicalizePath)
 import qualified Paths_stack as Meta
 import           Prelude -- Fix redundant import warnings
+import           Stack.Config (getInContainer)
 import           Stack.Constants
 import           Stack.Docker.GlobalDB
 import           Stack.Types
 import           Stack.Types.Internal
 import           Stack.Setup (ensureDockerStackExe)
 import           System.Directory (canonicalizePath,getHomeDirectory)
-import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath
-                                    ,lookupEnv)
+import           System.Environment (getEnv,getEnvironment,getProgName,getArgs,getExecutablePath)
 import           System.Exit (exitSuccess, exitWith)
 import qualified System.FilePath as FP
 import           System.IO (stderr,stdin,stdout,hIsTerminalDevice)
@@ -238,10 +238,6 @@ preventInContainer inner =
         then throwM OnlyOnHostException
         else inner
 
--- | 'True' if we are currently running inside a Docker container.
-getInContainer :: (MonadIO m) => m Bool
-getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
-
 -- | Run a command in a new Docker container, then exit the process.
 runContainerAndExit :: M env m
   => GetCmdArgs env m
@@ -878,10 +874,6 @@ fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
 oldSandboxIdEnvVar :: String
 oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
 
--- | Environment variable used to indicate stack is running in container.
-inContainerEnvVar :: String
-inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
-
 -- | Command-line argument for "docker"
 dockerCmdName :: String
 dockerCmdName = "docker"

src/Stack/Options.hs

@@ -288,7 +288,7 @@ cleanOptsParser = CleanTargets <$> packages <|> CleanFull <$> doFullClean
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser hide0 =
-    (\workDir dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
+    (\workDir dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty
         { configMonoidWorkDir = workDir
         , configMonoidDockerOpts = dockerOpts
         , configMonoidNixOpts = nixOpts
@@ -304,6 +304,7 @@ configOptsParser hide0 =
         , configMonoidSkipMsys = skipMsys
         , configMonoidLocalBinPath = localBin
         , configMonoidModifyCodePage = modifyCodePage
+        , configMonoidAllowDifferentUser = allowDifferentUser
         })
     <$> optional (strOption
             ( long "work-dir"
@@ -371,6 +372,11 @@ configOptsParser hide0 =
             "modify-code-page"
             "setting the codepage to support UTF-8 (Windows only)"
             hide
+    <*> maybeBoolFlags
+            "allow-different-user"
+            ("permission for users other than the owner of the stack root " ++
+                "directory to use a stack installation (POSIX only)")
+            hide
   where hide = hideMods hide0
 
 nixOptsParser :: Bool -> Parser NixOptsMonoid