diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index ac2ef0d32b..a1d32ae748 100644 --- a/doc/yaml_configuration.md +++ b/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. diff --git a/src/Path/Find.hs b/src/Path/Find.hs index fc98b83138..0879eac17e 100644 --- a/src/Path/Find.hs +++ b/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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index d348b8f02f..940a6df5fe 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 @@ -768,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 :| [pkgDir]) + let envSettings = EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = False diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 6cee6edcee..8ddf1593ca 100644 --- a/src/Stack/Config.hs +++ b/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 diff --git a/src/Stack/Constants.hs-boot b/src/Stack/Constants.hs-boot new file mode 100644 index 0000000000..df678d5bd0 --- /dev/null +++ b/src/Stack/Constants.hs-boot @@ -0,0 +1,3 @@ +module Stack.Constants where + +stackRootEnvVar :: String diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 420f189462..dcf94cedef 100644 --- a/src/Stack/Options.hs +++ b/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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 8b4d22eead..d9b70125ef 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -159,6 +159,7 @@ import Distribution.Version (anyVersion) import Network.HTTP.Client (parseUrl) import Path import qualified Paths_stack as Meta +import {-# SOURCE #-} Stack.Constants (stackRootEnvVar) import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import Stack.Types.Compiler import Stack.Types.Docker @@ -278,6 +279,9 @@ data Config = ,configDefaultTemplate :: !(Maybe TemplateName) -- ^ The default template to use when none is specified. -- (If Nothing, the default default is used.) + ,configAllowDifferentUser :: !Bool + -- ^ Allow users other than the stack root owner to use the stack + -- installation. } -- | Which packages to ghc-options on the command line apply to? @@ -806,6 +810,9 @@ data ConfigMonoid = ,configMonoidDefaultTemplate :: !(Maybe TemplateName) -- ^ The default template to use when none is specified. -- (If Nothing, the default default is used.) + , configMonoidAllowDifferentUser :: !(Maybe Bool) + -- ^ Allow users other than the stack root owner to use the stack + -- installation. } deriving Show @@ -845,6 +852,7 @@ instance Monoid ConfigMonoid where , configMonoidApplyGhcOptions = Nothing , configMonoidAllowNewer = Nothing , configMonoidDefaultTemplate = Nothing + , configMonoidAllowDifferentUser = Nothing } mappend l r = ConfigMonoid { configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r @@ -882,6 +890,7 @@ instance Monoid ConfigMonoid where , configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r , configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r , configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r + , configMonoidAllowDifferentUser = configMonoidAllowDifferentUser l <|> configMonoidAllowDifferentUser r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -946,6 +955,7 @@ parseConfigMonoidJSON obj = do configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName + configMonoidAllowDifferentUser <- obj ..:? configMonoidAllowDifferentUserName return ConfigMonoid {..} where @@ -1074,6 +1084,9 @@ configMonoidAllowNewerName = "allow-newer" configMonoidDefaultTemplateName :: Text configMonoidDefaultTemplateName = "default-template" +configMonoidAllowDifferentUserName :: Text +configMonoidAllowDifferentUserName = "allow-different-user" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseResolverException Text @@ -1086,6 +1099,9 @@ data ConfigException | ResolverPartial Resolver String | NoSuchDirectory FilePath | ParseGHCVariantException String + | BadStackRootEnvVar (Path Abs Dir) + | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir + | UserDoesn'tOwnDirectory (Path Abs Dir) deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1160,6 +1176,30 @@ instance Show ConfigException where [ "Invalid ghc-variant value: " , v ] + show (BadStackRootEnvVar envStackRoot) = concat + [ "Invalid $" + , stackRootEnvVar + , ": '" + , toFilePath envStackRoot + , "'. Please provide a valid absolute path." + ] + show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat + [ "Preventing creation of $" + , stackRootEnvVar + , " '" + , toFilePath envStackRoot + , "'. Parent directory '" + , toFilePath parentDir + , "' is owned by someone else." + ] + show (UserDoesn'tOwnDirectory dir) = concat + [ "You are not the owner of '" + , toFilePath dir + , "'. Aborting to protect file permissions." + , "\nRetry with '--" + , T.unpack configMonoidAllowDifferentUserName + , "' to disable this precaution." + ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig