From c6b1f959868905e2c7e93af48966351134ddbfed Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 26 May 2026 21:20:04 +0100 Subject: [PATCH 1/2] Fix #6915 `config set` recreates global-project directory, when needed --- ChangeLog.md | 3 + package.yaml | 1 + src/Stack/Config.hs | 126 +++++++++++------- src/Stack/ConfigCmd.hs | 35 ++--- src/Stack/Types/ConfigExtra.hs | 30 +++++ stack.cabal | 3 +- .../6915-config-set-inside-project/Main.hs | 103 ++++++++++++++ .../files/.gitignore | 0 .../files/myPackage.cabal | 9 ++ .../files/package.yaml | 3 + .../files/stack-alt.yaml | 21 +++ .../files/stack.yaml | 1 + .../6915-config-set-outside-project/Main.hs | 25 ++++ 13 files changed, 286 insertions(+), 74 deletions(-) create mode 100644 src/Stack/Types/ConfigExtra.hs create mode 100644 tests/integration/tests/6915-config-set-inside-project/Main.hs create mode 100644 tests/integration/tests/6915-config-set-inside-project/files/.gitignore create mode 100644 tests/integration/tests/6915-config-set-inside-project/files/myPackage.cabal create mode 100644 tests/integration/tests/6915-config-set-inside-project/files/package.yaml create mode 100644 tests/integration/tests/6915-config-set-inside-project/files/stack-alt.yaml create mode 100644 tests/integration/tests/6915-config-set-inside-project/files/stack.yaml create mode 100644 tests/integration/tests/6915-config-set-outside-project/Main.hs diff --git a/ChangeLog.md b/ChangeLog.md index 438070e61a..2d51f41e67 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -55,6 +55,9 @@ Bug fixes: depends on project package B and package B's executables (only) depend on package A and the name of A is before that of B, alphabetically. That bug is fixed. +* Stack's `config set` commands will recreate the `global-project` directory + contents, if Stack needs to consult its project-level configuration file and + there is no file. ## v3.9.3 - 2026-02-19 diff --git a/package.yaml b/package.yaml index 42f8aa4354..837fae43c2 100644 --- a/package.yaml +++ b/package.yaml @@ -304,6 +304,7 @@ library: - Stack.Types.Component - Stack.Types.ComponentUtils - Stack.Types.Config + - Stack.Types.ConfigExtra - Stack.Types.Config.Exception - Stack.Types.ConfigMonoid - Stack.Types.ConfigSetOpts diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 151ec82e6a..fe99bb602e 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -33,6 +33,7 @@ module Stack.Config , defaultConfigYaml , getProjectConfig , withBuildConfig + , withConfigExtra , withNewLogFunc , determineStackRootAndOwnership ) where @@ -126,6 +127,7 @@ import Stack.Types.Config.Exception ( ConfigException (..), ConfigPrettyException (..) , ParseAbsolutePathException (..) ) +import Stack.Types.ConfigExtra ( ConfigExtra (..) ) import Stack.Types.ConfigMonoid ( ConfigMonoid (..), parseConfigMonoid ) import Stack.Types.Casa ( CasaOptsMonoid (..) ) @@ -786,32 +788,77 @@ loadConfig inner = do -- by @loadConfig@. values. withBuildConfig :: RIO BuildConfig a -> RIO Config a withBuildConfig inner = do - config <- ask + withConfigExtra True $ \configExtra -> do + -- The mcompiler is provided on the command line. + mcompiler <- view $ globalOptsL . to (.compiler) + let config = configExtra.config + project' = configExtra.project + configFile = configExtra.configFile + project :: Project + project = project' + { Project.compiler = mcompiler <|> project'.compiler + , Project.snapshot = fromMaybe project'.snapshot configExtra.mSnapshot + } + -- We are indifferent as to whether the configuration file is a + -- user-specific global or a project-level one. + eitherConfigFile = EE.fromEither configFile + extraPackageDBs <- mapM resolveDir' project.extraPackageDBs + + smWanted <- lockCachedWanted eitherConfigFile project.snapshot $ + fillProjectWanted eitherConfigFile config project + + -- Unfortunately redoes getWorkDir, since we don't have a BuildConfig yet + workDir <- view workDirL + let projectStorageFile = + parent eitherConfigFile workDir relFileStorage + + initProjectStorage projectStorageFile $ \projectStorage -> do + let bc = BuildConfig + { config + , smWanted + , extraPackageDBs + , configFile + , curator = project.curator + , projectStorage + } + runRIO bc inner +-- | Adds certain build-specific values to the configuration loaded by +-- @loadConfig@ values. +withConfigExtra :: + forall a env. (HasConfig env, HasTerm env) + => Bool + -- ^ Report user message in the project-level configuration file, if + -- a user message is present? + -> (ConfigExtra -> RIO env a) + -> RIO env a +withConfigExtra reportUserMessage inner = do + config <- view configL -- If provided, turn the AbstractSnapshot from the command line into a - -- snapshot that can be used below. + -- snapshot that can be used. - -- The snapshot and mcompiler are provided on the command line. In order - -- to properly deal with an AbstractSnapshot, we need a base directory (to - -- deal with custom snapshot relative paths). We consider the current working - -- directory to be the correct base. Let's calculate the mSnapshot first. + -- The snapshot is provided on the command line. In order to properly deal + -- with an AbstractSnapshot, we need a base directory (to deal with custom + -- snapshot relative paths). We consider the current working directory to be + -- the correct base. We calculate the mSnapshot first. mSnapshot <- forM config.snapshot $ \aSnapshot -> do logDebug $ - "Using snapshot: " - <> display aSnapshot - <> " specified on command line" + "Using snapshot: " + <> display aSnapshot + <> " specified on command line" makeConcreteSnapshot aSnapshot - (project', configFile) <- case config.project of + (project, configFile) <- case config.project of PCProject (project, fp) -> do - forM_ project.userMsg prettyUserMessage + when reportUserMessage $ + forM_ project.userMsg prettyUserMessage pure (project, Right fp) PCNoProject extraDeps -> do - p <- + project <- case mSnapshot of Nothing -> throwIO NoSnapshotWhenUsingNoProject Just _ -> getEmptyProject mSnapshot extraDeps - pure (p, Left config.userGlobalConfigFile) + pure (project, Left config.userGlobalConfigFile) PCGlobalProject -> do logDebug "Run from outside a project, using implicit global project config" destDir <- getImplicitGlobalProjectDir @@ -844,7 +891,7 @@ withBuildConfig inner = do , style Shell "snapshot" , flow "key there." ] - p <- getEmptyProject mSnapshot [] + project <- getEmptyProject mSnapshot [] liftIO $ do writeBinaryFileAtomic dest $ byteString $ S.concat [ "# This is the implicit global project's configuration file, which is only used\n" @@ -855,45 +902,24 @@ withBuildConfig inner = do , "# For more information about Stack's configuration, see\n" , "# http://docs.haskellstack.org/en/stable/configure/yaml/\n" , "#\n" - , Yaml.encode p] - writeBinaryFileAtomic (parent dest relFileReadmeTxt) $ - "This is the implicit global project, which is " <> - "used only when 'stack' is run\noutside of a " <> - "real project.\n" - pure (p, Right dest) - mcompiler <- view $ globalOptsL . to (.compiler) - let project :: Project - project = project' - { Project.compiler = mcompiler <|> project'.compiler - , Project.snapshot = fromMaybe project'.snapshot mSnapshot - } - -- We are indifferent as to whether the configuration file is a - -- user-specific global or a project-level one. - eitherConfigFile = EE.fromEither configFile - extraPackageDBs <- mapM resolveDir' project.extraPackageDBs - - smWanted <- lockCachedWanted eitherConfigFile project.snapshot $ - fillProjectWanted eitherConfigFile config project - - -- Unfortunately redoes getWorkDir, since we don't have a BuildConfig yet - workDir <- view workDirL - let projectStorageFile = parent eitherConfigFile workDir relFileStorage - - initProjectStorage projectStorageFile $ \projectStorage -> do - let bc = BuildConfig - { config - , smWanted - , extraPackageDBs - , configFile - , curator = project.curator - , projectStorage - } - runRIO bc inner + , Yaml.encode project + ] + writeBinaryFileAtomic (parent dest relFileReadmeTxt) $ mconcat + [ "This is the implicit global project, which is used only when 'stack' is run\n" + , "outside of a real project.\n" + ] + pure (project, Right dest) + inner $ ConfigExtra + { config + , mSnapshot + , project + , configFile + } where getEmptyProject :: Maybe RawSnapshotLocation -> [RawPackageLocationImmutable] - -> RIO Config Project + -> RIO env Project getEmptyProject mSnapshot extraDeps = do snapshot <- case mSnapshot of Just snapshot -> do @@ -921,7 +947,7 @@ withBuildConfig inner = do , curator = Nothing , dropPackages = mempty } - prettyUserMessage :: String -> RIO Config () + prettyUserMessage :: String -> RIO env () prettyUserMessage userMsg = do let userMsgs = map flow $ splitAtLineEnds userMsg warningDoc = mconcat $ intersperse blankLine userMsgs diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 635cd1b645..2dddf262ee 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -32,22 +32,18 @@ import qualified Data.Map.Merge.Strict as Map import qualified Data.Text as T import qualified Data.Yaml as Yaml import Pantry ( loadSnapshot ) -import Path ( (), parent ) +import Path ( parent ) import qualified RIO.Map as Map import RIO.NonEmpty ( nonEmpty ) import qualified RIO.NonEmpty as NE import RIO.Process ( envVarsL ) -import Stack.Config - ( makeConcreteSnapshot, getProjectConfig - , getImplicitGlobalProjectDir - ) -import Stack.Constants ( stackDotYaml ) +import Stack.Config ( makeConcreteSnapshot, withConfigExtra ) import Stack.Prelude import Stack.Types.BuildConfig ( BuildConfig ) import Stack.Types.Config ( Config (..), HasConfig (..) ) +import Stack.Types.ConfigExtra ( ConfigExtra (..) ) import Stack.Types.ConfigMonoid - ( configMonoidInstallGHCName - , configMonoidInstallMsysName + ( configMonoidInstallGHCName, configMonoidInstallMsysName , configMonoidRecommendStackUpgradeName , configMonoidSystemGHCName ) @@ -56,9 +52,6 @@ import Stack.Types.ConfigSetOpts import Stack.Types.EnvConfig ( EnvConfig ) import Stack.Types.EnvSettings ( EnvSettings (..) ) import Stack.Types.GHCVariant ( HasGHCVariant ) -import Stack.Types.GlobalOpts ( GlobalOpts (..) ) -import Stack.Types.ProjectConfig ( ProjectConfig (..) ) -import Stack.Types.Runner ( globalOptsL ) import Stack.Types.Snapshot ( AbstractSnapshot ) import System.Environment ( getEnvironment ) @@ -95,18 +88,14 @@ instance Exception ConfigCmdPrettyException cfgCmdSet :: (HasConfig env, HasGHCVariant env) => ConfigCmdSet -> RIO env () -cfgCmdSet cmd = do - conf <- view configL - configFilePath <- - case configCmdSetScope cmd of - CommandScopeProject -> do - mstackYamlOption <- view $ globalOptsL . to (.stackYaml) - mstackYaml <- getProjectConfig mstackYamlOption - case mstackYaml of - PCProject stackYaml -> pure stackYaml - PCGlobalProject -> getImplicitGlobalProjectDir <&> ( stackDotYaml) - PCNoProject _extraDeps -> prettyThrowIO NoProjectConfigAvailable - -- maybe modify the ~/.stack/config.yaml file instead? +-- We ignore any user message in the project-level configuration file: +cfgCmdSet cmd = withConfigExtra False $ \configExtra -> do + let conf = configExtra.config + configFilePath <- case configCmdSetScope cmd of + CommandScopeProject -> case configExtra.configFile of + Left _ -> prettyThrowIO NoProjectConfigAvailable + -- Maybe modify the global configuration file (config.yaml) instead? + Right fp -> pure fp CommandScopeGlobal -> pure conf.userGlobalConfigFile rawConfig <- liftIO (readFileUtf8 (toFilePath configFilePath)) config <- either throwM pure (Yaml.decodeEither' $ encodeUtf8 rawConfig) diff --git a/src/Stack/Types/ConfigExtra.hs b/src/Stack/Types/ConfigExtra.hs new file mode 100644 index 0000000000..4737cdff40 --- /dev/null +++ b/src/Stack/Types/ConfigExtra.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +{-| +Module : Stack.Types.ConfigExtra +License : BSD-3-Clause +-} + +module Stack.Types.ConfigExtra + ( ConfigExtra (..) + ) where + +import Stack.Prelude +import Stack.Types.Config ( Config ) +import Stack.Types.Project ( Project (..) ) + +-- | A type that represents 'Config' values together with some extra information +-- +data ConfigExtra = ConfigExtra + { config :: !Config + , mSnapshot :: !(Maybe RawSnapshotLocation) + , project :: !Project + , configFile :: !(Either (Path Abs File) (Path Abs File)) + -- ^ Either (Left) the location of the user-specific global configuration + -- file or, in most cases, (Right) the location of the project-level + -- coniguration file (stack.yaml, by default). + -- + -- Note: if the STACK_YAML environment variable is used, the location of the + -- project-level configuration file may be different from + -- projectRootL "stack.yaml" if a different file name is used. + } diff --git a/stack.cabal b/stack.cabal index e32080aef3..49d82d2d15 100644 --- a/stack.cabal +++ b/stack.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.5. -- -- see: https://github.com/sol/hpack @@ -340,6 +340,7 @@ library Stack.Types.Component Stack.Types.ComponentUtils Stack.Types.Config + Stack.Types.ConfigExtra Stack.Types.Config.Exception Stack.Types.ConfigMonoid Stack.Types.ConfigSetOpts diff --git a/tests/integration/tests/6915-config-set-inside-project/Main.hs b/tests/integration/tests/6915-config-set-inside-project/Main.hs new file mode 100644 index 0000000000..81e7e76e57 --- /dev/null +++ b/tests/integration/tests/6915-config-set-inside-project/Main.hs @@ -0,0 +1,103 @@ +-- Stack's config set commands should work as expected. + +import Control.Monad ( unless ) +import Data.List ( isInfixOf ) +import StackTest + +main :: IO () +main = do + stackCheckStderr + ["config", "set", "snapshot", "ghc-9.10.2"] + (expectMessage hasBeenUpdated) + stackCheckStderr + ["config", "set", "snapshot", "ghc-9.10.2"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "snapshot", "ghc-9.10.3"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "system-ghc", "false"] + (expectMessage hasBeenExtended) + stackCheckStderr + ["config", "set", "system-ghc", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "system-ghc", "true"] + (expectMessage hasBeenUpdated) + stackCheckStderr + ["config", "set", "system-ghc", "true"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "system-ghc", "true"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "install-ghc", "true"] + (expectMessage hasBeenExtended) + stackCheckStderr + ["config", "set", "install-ghc", "true"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "install-ghc", "false"] + (expectMessage hasBeenUpdated) + stackCheckStderr + ["config", "set", "install-ghc", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "install-ghc", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "install-msys", "true"] + (expectMessage hasBeenExtended) + stackCheckStderr + ["config", "set", "install-msys", "true"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "install-msys", "false"] + (expectMessage hasBeenUpdated) + stackCheckStderr + ["config", "set", "install-msys", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "install-msys", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "recommend-stack-upgrade", "--project", "true"] + (expectMessage hasBeenExtended) + stackCheckStderr + ["config", "set", "recommend-stack-upgrade", "--project", "true"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "recommend-stack-upgrade", "--project", "false"] + (expectMessage hasBeenUpdated) + stackCheckStderr + ["config", "set", "recommend-stack-upgrade", "--project", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "recommend-stack-upgrade", "--project", "false"] + (expectMessage alreadyContained) + stackCheckStderr + ["config", "set", "package-index", "download-prefix", "https://hackage.haskell.org/"] + (expectMessage hasBeenExtended) + stackCheckStderr + ["config", "set", "package-index", "download-prefix", "https://hackage.haskell.org/"] + (expectMessage alreadyContained) + stackCheckStderr + ["--stack-yaml", "stack-alt.yaml", "config", "set", "package-index", "download-prefix", "https://hackage.haskell.org/"] + (expectMessage alreadyContained) + +hasBeenUpdated :: String +hasBeenUpdated = + "has been updated." + +alreadyContained :: String +alreadyContained = + "already contained the intended configuration and remains unchanged." + +hasBeenExtended :: String +hasBeenExtended = + "has been extended." + +expectMessage :: String -> String -> IO () +expectMessage msg stderr = do + unless (words msg `isInfixOf` words stderr) $ + error $ "Expected output: \n" ++ show msg diff --git a/tests/integration/tests/6915-config-set-inside-project/files/.gitignore b/tests/integration/tests/6915-config-set-inside-project/files/.gitignore new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/integration/tests/6915-config-set-inside-project/files/myPackage.cabal b/tests/integration/tests/6915-config-set-inside-project/files/myPackage.cabal new file mode 100644 index 0000000000..e4596c30a3 --- /dev/null +++ b/tests/integration/tests/6915-config-set-inside-project/files/myPackage.cabal @@ -0,0 +1,9 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.39.5. +-- +-- see: https://github.com/sol/hpack + +name: myPackage +version: 0.0.0 +build-type: Simple diff --git a/tests/integration/tests/6915-config-set-inside-project/files/package.yaml b/tests/integration/tests/6915-config-set-inside-project/files/package.yaml new file mode 100644 index 0000000000..0a64c2a06a --- /dev/null +++ b/tests/integration/tests/6915-config-set-inside-project/files/package.yaml @@ -0,0 +1,3 @@ +spec-version: 0.36.0 + +name: myPackage diff --git a/tests/integration/tests/6915-config-set-inside-project/files/stack-alt.yaml b/tests/integration/tests/6915-config-set-inside-project/files/stack-alt.yaml new file mode 100644 index 0000000000..5157d72ac5 --- /dev/null +++ b/tests/integration/tests/6915-config-set-inside-project/files/stack-alt.yaml @@ -0,0 +1,21 @@ +snapshot: ghc-9.10.3 + +system-ghc: true + +install-ghc: false + +install-msys: false + +recommend-stack-upgrade: false + +package-index: + download-prefix: https://hackage.haskell.org/ + hackage-security: + keyids: + - 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d + - 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42 + - 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921 + - c7de58fc6a224b92b5b513f26fbb8b370f2d97c7cfe0075a951314a55734be93 + - fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0 + key-threshold: 3 + ignore-expiry: true diff --git a/tests/integration/tests/6915-config-set-inside-project/files/stack.yaml b/tests/integration/tests/6915-config-set-inside-project/files/stack.yaml new file mode 100644 index 0000000000..e674eab75a --- /dev/null +++ b/tests/integration/tests/6915-config-set-inside-project/files/stack.yaml @@ -0,0 +1 @@ +snapshot: ghc-9.10.3 diff --git a/tests/integration/tests/6915-config-set-outside-project/Main.hs b/tests/integration/tests/6915-config-set-outside-project/Main.hs new file mode 100644 index 0000000000..f391e15e58 --- /dev/null +++ b/tests/integration/tests/6915-config-set-outside-project/Main.hs @@ -0,0 +1,25 @@ +-- Stack's config set commands should recreate the global-project directory, if +-- Stack needs to consult its project-level configuration file and there is no +-- file. +-- +-- See: https://github.com/commercialhaskell/stack/issues/6915 + +import Control.Monad ( unless ) +import Data.List ( isInfixOf ) +import StackTest + +main :: IO () +main = do + -- In a clean Stack root, there is no global-projects directory. + stackCheckStderr + ["config", "set", "install-ghc", "false"] + (expectMessage writingConfigFile) + +writingConfigFile :: String +writingConfigFile = + "Writing the configuration file for the implicit global project to:" + +expectMessage :: String -> String -> IO () +expectMessage msg stderr = do + unless (words msg `isInfixOf` words stderr) $ + error $ "Expected output: \n" ++ show msg From 3f82f900c6d1f350213b6e1220119fa305617bd6 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Tue, 26 May 2026 21:21:57 +0100 Subject: [PATCH 2/2] Fix minor typos --- src/Stack/Types/ProjectConfig.hs | 2 +- tests/integration/tests/3770-no-rerun-tests/Main.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Stack/Types/ProjectConfig.hs b/src/Stack/Types/ProjectConfig.hs index 412b07b5cc..60e38093dc 100644 --- a/src/Stack/Types/ProjectConfig.hs +++ b/src/Stack/Types/ProjectConfig.hs @@ -24,7 +24,7 @@ data ProjectConfig a -- Instead, use the implicit global. | PCNoProject ![RawPackageLocationImmutable] -- ^ Use a no project run. This comes from - -- 'Stack.Types.StackYamlLocSYLNoProject'. + -- 'Stack.Types.StackYamlLoc.SYLNoProject'. -- | Yields 'True' only if the project configuration information is for the -- implicit global project. diff --git a/tests/integration/tests/3770-no-rerun-tests/Main.hs b/tests/integration/tests/3770-no-rerun-tests/Main.hs index 6a08206e94..a4c98951aa 100644 --- a/tests/integration/tests/3770-no-rerun-tests/Main.hs +++ b/tests/integration/tests/3770-no-rerun-tests/Main.hs @@ -2,9 +2,9 @@ -- -- See: https://github.com/commercialhaskell/stack/pull/3770 -import Control.Monad ( unless ) -import Data.List ( isInfixOf ) -import StackTest +import Control.Monad ( unless ) +import Data.List ( isInfixOf ) +import StackTest main :: IO () main = do