Merge pull request #1599 from sjakobi/471-check-for-sudo

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

doc/yaml_configuration.md

@@ -435,6 +435,20 @@ 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`.
+
 ### 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

@@ -43,6 +43,7 @@ import           Data.Foldable (forM_, any)
 import           Data.Function
 import           Data.IORef.RunOnce (runOnce)
 import           Data.List hiding (any)
+import           Data.List.NonEmpty (NonEmpty(..))
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -70,6 +71,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 +771,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
 
     withCabal package pkgDir mlogFile inner = do
         config <- asks getConfig
+
+        unless (configAllowDifferentUser config) $
+            checkOwnership (pkgDir </> configWorkDir config :| [pkgDir])
+
         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,7 @@ module Stack.Config
   ,getIsGMP4
   ,getSnapshots
   ,makeConcreteResolver
+  ,checkOwnership
   ) where
 
 import qualified Codec.Archive.Tar as Tar
@@ -40,6 +42,7 @@ import           Control.Arrow ((***))
 import           Control.Exception (assert)
 import           Control.Monad
 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)
@@ -50,6 +53,8 @@ import qualified Data.ByteString as S
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Lazy as L
 import qualified Data.IntMap as IntMap
+import           Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as Map
 import           Data.Maybe
 import           Data.Monoid
@@ -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.
@@ -288,6 +295,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c
          configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions
          configAllowNewer = fromMaybe False configMonoidAllowNewer
          configDefaultTemplate = configMonoidDefaultTemplate
+         configAllowDifferentUser = fromMaybe False configMonoidAllowDifferentUser
 
      return Config {..}
 
@@ -365,7 +373,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 +395,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 :| [dir])
+
     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 +627,78 @@ 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' dirs@ throws 'UserDoesn'tOwnDirectory' if the first
+-- existing directory of @dirs@ isn't owned by the current user.
+--
+-- If none of the directories exist, throws @'NoSuchDirectory' lastDir@, where
+-- @lastDir@ is @last dirs@.
+checkOwnership :: (MonadIO m, MonadCatch m) => NonEmpty (Path Abs Dir) -> m ()
+checkOwnership dirs = do
+    mdirAndOwnership <- firstJustM getDirAndOwnership (NE.toList dirs)
+    case mdirAndOwnership of
+        Just (_, True) -> return ()
+        Just (dir, False) -> throwM (UserDoesn'tOwnDirectory dir)
+        Nothing ->
+            (throwM . NoSuchDirectory . toFilePathNoTrailingSep . NE.last) dirs
+
+-- | @'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
 
 -- | Determine the extra config file locations which exist.
 --
@@ -665,21 +744,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-boot

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

src/Stack/Options.hs

@@ -287,7 +287,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
@@ -303,6 +303,7 @@ configOptsParser hide0 =
         , configMonoidSkipMsys = skipMsys
         , configMonoidLocalBinPath = localBin
         , configMonoidModifyCodePage = modifyCodePage
+        , configMonoidAllowDifferentUser = allowDifferentUser
         })
     <$> optional (strOption
             ( long "work-dir"
@@ -370,6 +371,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