Merge pull request #4701 from commercialhaskell/3887-basic-config-in-…

…script-2

Load up user config when using scripts

.azure/azure-nightly-template-linux.yml

@@ -37,7 +37,7 @@ jobs:
       # FIXME: Note that cabal-install might not be required once
       # https://github.com/commercialhaskell/stack/issues/4410 get's
       # fixed.
-      stack test --flag stack:integration-tests stack:test:stack-integration-test --interleaved-output
+      etc/scripts/integration-tests.sh
       set +ex
     displayName: Integration Test
   - script: |

.azure/azure-nightly-template-osx.yml

@@ -39,7 +39,7 @@ jobs:
       # FIXME: Note that cabal-install might not be required once
       # https://github.com/commercialhaskell/stack/issues/4410 get's
       # fixed.
-      stack test --flag stack:integration-tests stack:test:stack-integration-test --interleaved-output
+      etc/scripts/integration-tests.sh
       set +ex
     displayName: Integration Test
   - script: |

.azure/azure-nightly-template-windows.yml

@@ -43,7 +43,7 @@ jobs:
       # FIXME: Note that cabal-install might not be required once
       # https://github.com/commercialhaskell/stack/issues/4410 get's
       # fixed.
-      stack test --flag stack:integration-tests stack:test:stack-integration-test --interleaved-output --no-terminal
+      etc/scripts/integration-tests.sh
       set +ex
     displayName: Integration Test
   - powershell: |

ChangeLog.md

@@ -178,6 +178,9 @@ Other enhancements:
   packages. See [#2465](https://github.com/commercialhaskell/stack/issues/2465)
 * Store caches in SQLite database instead of files.
 * No longer use "global" Docker image database (`docker.db`).
+* User config files are respected for the script command. See
+  [#3705](https://github.com/commercialhaskell/stack/issues/3705),
+  [#3887](https://github.com/commercialhaskell/stack/issues/3887).
 
 Bug fixes:
 

etc/scripts/integration-tests.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+exec stack build --flag stack:integration-tests stack --interleaved-output --exec stack-integration-test

package.yaml

@@ -277,17 +277,6 @@ executables:
       cpp-options: -DHIDE_DEP_VERSIONS
     - condition: flag(supported-build)
       cpp-options: -DSUPPORTED_BUILD
-tests:
-  stack-test:
-    main: Spec.hs
-    source-dirs: src/test
-    ghc-options:
-    - -threaded
-    dependencies:
-    - QuickCheck
-    - hspec
-    - stack
-    - smallcheck
   stack-integration-test:
     main: IntegrationSpec.hs
     source-dirs:
@@ -303,6 +292,17 @@ tests:
     when:
     - condition: ! '!(flag(integration-tests))'
       buildable: false
+tests:
+  stack-test:
+    main: Spec.hs
+    source-dirs: src/test
+    ghc-options:
+    - -threaded
+    dependencies:
+    - QuickCheck
+    - hspec
+    - stack
+    - smallcheck
 flags:
   static:
     description: Pass -static/-pthread to ghc when linking the stack binary.

src/Stack/Build/Target.hs

@@ -478,5 +478,5 @@ parseTargets needTargets haddockDeps boptscli smActual = do
     bcImplicitGlobal bconfig =
       case configProject $ bcConfig bconfig of
         PCProject _ -> False
-        PCNoProject -> True
-        PCNoConfig _ -> False
+        PCGlobalProject -> True
+        PCNoProject _ -> False

src/Stack/Config.hs

@@ -36,7 +36,6 @@ import           Control.Monad.Extra (firstJustM)
 import           Stack.Prelude
 import           Data.Aeson.Extended
 import qualified Data.ByteString as S
-import           Data.ByteString.Builder (toLazyByteString)
 import           Data.Coerce (coerce)
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
@@ -53,7 +52,6 @@ import           GHC.Conc (getNumProcessors)
 import           Lens.Micro ((.~))
 import           Network.HTTP.StackClient (httpJSON, parseUrlThrow, getResponseBody)
 import           Options.Applicative (Parser, strOption, long, help)
-import qualified Pantry.SHA256 as SHA256
 import           Path
 import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.Find (findInParents)
@@ -174,50 +172,32 @@ getLatestResolver = do
                listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
     pure $ fromMaybe (nightlySnapshotLocation (snapshotsNightly snapshots)) mlts
 
--- | Create a 'Config' value when we're not using any local
--- configuration files (e.g., the script command)
-configNoLocalConfig
-    :: HasRunner env
-    => Path Abs Dir -- ^ stack root
-    -> Maybe AbstractResolver
-    -> ConfigMonoid
-    -> [PackageIdentifierRevision]
-    -> (Config -> RIO env a)
-    -> RIO env a
-configNoLocalConfig _ Nothing _ _ _ = throwIO NoResolverWhenUsingNoLocalConfig
-configNoLocalConfig stackRoot (Just resolver) configMonoid extraDeps inner = do
-    userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver
-    configFromConfigMonoid
-      stackRoot
-      userConfigPath
-      False
-      (Just resolver)
-      (PCNoConfig extraDeps)
-      configMonoid
-      inner
-
 -- Interprets ConfigMonoid options.
 configFromConfigMonoid
     :: HasRunner env
     => Path Abs Dir -- ^ stack root, e.g. ~/.stack
     -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml
-    -> Bool -- ^ allow locals?
     -> Maybe AbstractResolver
     -> ProjectConfig (Project, Path Abs File)
     -> ConfigMonoid
     -> (Config -> RIO env a)
     -> RIO env a
 configFromConfigMonoid
-    configStackRoot configUserConfigPath configAllowLocals configResolver
+    configStackRoot configUserConfigPath configResolver
     configProject ConfigMonoid{..} inner = do
      -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK
      -- is set, use that. If neither, use the default ".stack-work"
      mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar
      let mproject =
            case configProject of
              PCProject pair -> Just pair
-             PCNoProject -> Nothing
-             PCNoConfig _deps -> Nothing
+             PCGlobalProject -> Nothing
+             PCNoProject _deps -> Nothing
+         configAllowLocals =
+           case configProject of
+             PCProject _ -> True
+             PCGlobalProject -> True
+             PCNoProject _ -> False
      configWorkDir0 <- maybe (return relDirStackWork) (liftIO . parseRelDir) mstackWorkEnv
      let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir
          configLatestSnapshot = fromFirst
@@ -355,8 +335,16 @@ configFromConfigMonoid
          Nothing -> pure defaultHackageSecurityConfig
          Just [hsc] -> pure hsc
          Just x -> error $ "When overriding the default package index, you must provide exactly one value, received: " ++ show x
+     mpantryRoot <- liftIO $ lookupEnv "PANTRY_ROOT"
+     pantryRoot <-
+       case mpantryRoot of
+         Just dir ->
+           case parseAbsDir dir of
+             Nothing -> throwString $ "Failed to parse PANTRY_ROOT environment variable (expected absolute directory): " ++ show dir
+             Just x -> pure x
+         Nothing -> pure $ configStackRoot </> relDirPantry
      withPantryConfig
-       (configStackRoot </> relDirPantry)
+       pantryRoot
        hsc
        (maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack)
        clConnectionCount
@@ -402,32 +390,26 @@ loadConfig inner = do
     let (mproject', addConfigMonoid) =
           case mproject of
             PCProject (proj, fp, cm) -> (PCProject (proj, fp), (cm:))
-            PCNoProject -> (PCNoProject, id)
-            PCNoConfig deps -> (PCNoConfig deps, id)
-    let loadHelper inner2 = do
-          userConfigPath <- getDefaultUserConfigPath stackRoot
-          extraConfigs0 <- getExtraConfigs userConfigPath >>=
-              mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)
-          let extraConfigs =
-                -- non-project config files' existence of a docker section should never default docker
-                -- to enabled, so make it look like they didn't exist
-                map (\c -> c {configMonoidDockerOpts =
-                                  (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})
-                    extraConfigs0
-
+            PCGlobalProject -> (PCGlobalProject, id)
+            PCNoProject deps -> (PCNoProject deps, id)
+
+    userConfigPath <- getDefaultUserConfigPath stackRoot
+    extraConfigs0 <- getExtraConfigs userConfigPath >>=
+        mapM (\file -> loadConfigYaml (parseConfigMonoid (parent file)) file)
+    let extraConfigs =
+          -- non-project config files' existence of a docker section should never default docker
+          -- to enabled, so make it look like they didn't exist
+          map (\c -> c {configMonoidDockerOpts =
+                            (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})
+              extraConfigs0
+
+    let withConfig =
           configFromConfigMonoid
             stackRoot
             userConfigPath
-            True -- allow locals
             mresolver
             mproject'
             (mconcat $ configArgs : addConfigMonoid extraConfigs)
-            inner2
-
-    let withConfig = case mproject of
-          PCNoConfig extraDeps -> configNoLocalConfig stackRoot mresolver configArgs extraDeps
-          PCProject _project -> loadHelper
-          PCNoProject -> loadHelper
 
     withConfig $ \config -> do
       unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config)
@@ -461,10 +443,13 @@ loadBuildConfig = do
       PCProject (project, fp) -> do
           forM_ (projectUserMsg project) (logWarn . fromString)
           return (project, fp)
-      PCNoConfig extraDeps -> do
-          p <- assert (isJust mresolver) (getEmptyProject mresolver extraDeps)
+      PCNoProject extraDeps -> do
+          p <-
+            case mresolver of
+              Nothing -> throwIO NoResolverWhenUsingNoProject
+              Just _ -> getEmptyProject mresolver extraDeps
           return (p, configUserConfigPath config)
-      PCNoProject -> do
+      PCGlobalProject -> do
             logDebug "Run from outside a project, using implicit global project config"
             destDir <- getImplicitGlobalProjectDir config
             let dest :: Path Abs File
@@ -752,7 +737,7 @@ getProjectConfig :: HasLogFunc env
                  -- ^ Override stack.yaml
                  -> RIO env (ProjectConfig (Path Abs File))
 getProjectConfig (SYLOverride stackYaml) = return $ PCProject stackYaml
-getProjectConfig SYLNoProject = return PCNoProject
+getProjectConfig SYLGlobalProject = return PCGlobalProject
 getProjectConfig SYLDefault = do
     env <- liftIO getEnvironment
     case lookup "STACK_YAML" env of
@@ -761,7 +746,7 @@ getProjectConfig SYLDefault = do
             liftM PCProject $ resolveFile' fp
         Nothing -> do
             currDir <- getCurrentDir
-            maybe PCNoProject PCProject <$> findInParents getStackDotYaml currDir
+            maybe PCGlobalProject PCProject <$> findInParents getStackDotYaml currDir
   where
     getStackDotYaml dir = do
         let fp = dir </> stackDotYaml
@@ -771,7 +756,7 @@ getProjectConfig SYLDefault = do
         if exists
             then return $ Just fp
             else return Nothing
-getProjectConfig (SYLNoConfig extraDeps) = return $ PCNoConfig extraDeps
+getProjectConfig (SYLNoProject extraDeps) = return $ PCNoProject extraDeps
 
 -- | Find the project config file location, respecting environment variables
 -- and otherwise traversing parents. If no config is found, we supply a default
@@ -788,12 +773,12 @@ loadProjectConfig mstackYaml = do
             logDebug $ "Loading project config file " <>
                         fromString (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp))
             PCProject <$> load fp
-        PCNoProject -> do
+        PCGlobalProject -> do
             logDebug "No project config file found, using defaults."
-            return PCNoProject
-        PCNoConfig extraDeps -> do
+            return PCGlobalProject
+        PCNoProject extraDeps -> do
             logDebug "Ignoring config files"
-            return $ PCNoConfig extraDeps
+            return $ PCNoProject extraDeps
   where
     load fp = do
         iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
@@ -835,29 +820,6 @@ getDefaultUserConfigPath stackRoot = do
         liftIO $ S.writeFile (toFilePath path) defaultConfigYaml
     return path
 
--- | Get a fake configuration file location, used when doing a "no
--- config" run (the script command).
-getFakeConfigPath
-    :: (MonadIO m, MonadThrow m)
-    => Path Abs Dir -- ^ stack root
-    -> AbstractResolver
-    -> m (Path Abs File)
-getFakeConfigPath stackRoot ar = do
-  asString <-
-    case ar of
-      ARResolver r -> pure $ T.unpack $ SHA256.toHexText $ SHA256.hashLazyBytes $ toLazyByteString $ getUtf8Builder $ display r
-      _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar
-  -- This takeWhile is an ugly hack. We don't actually need this
-  -- path for anything useful. But if we take the raw value for
-  -- a custom snapshot, it will be unparseable in a PATH.
-  -- Therefore, we add in this silly "strip up to :".
-  -- Better would be to defer figuring out this value until
-  -- after we have a fully loaded snapshot with a hash.
-  asDir <- parseRelDir $ takeWhile (/= ':') asString
-  let full = stackRoot </> relDirScript </> asDir </> relFileConfigYaml
-  ensureDir (parent full)
-  return full
-
 packagesParser :: Parser [String]
 packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
 

src/Stack/ConfigCmd.hs

@@ -66,8 +66,8 @@ cfgCmdSet cmd = do
                      mstackYaml <- getProjectConfig mstackYamlOption
                      case mstackYaml of
                          PCProject stackYaml -> return stackYaml
-                         PCNoProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
-                         PCNoConfig _extraDeps -> throwString "config command used when no local configuration available"
+                         PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
+                         PCNoProject _extraDeps -> throwString "config command used when no project configuration available" -- maybe modify the ~/.stack/config.yaml file instead?
                  CommandScopeGlobal -> return (configUserConfigPath conf)
     -- We don't need to worry about checking for a valid yaml here
     (config :: Yaml.Object) <-

src/Stack/Freeze.hs

@@ -26,8 +26,8 @@ freeze (FreezeOpts mode) = do
   let warn = logWarn "No project was found: nothing to freeze"
   case mproject of
     PCProject (p, _) -> doFreeze p mode
-    PCNoProject -> warn
-    PCNoConfig _ -> warn
+    PCGlobalProject -> warn
+    PCNoProject _ -> warn
 
 doFreeze ::
        (HasProcessContext env, HasLogFunc env, HasPantryConfig env)

src/Stack/Options/Completion.hs

@@ -85,8 +85,8 @@ flagCompleter = buildConfigCompleter $ \input -> do
         prjFlags =
           case configProject (bcConfig bconfig) of
             PCProject (p, _) -> projectFlags p
-            PCNoProject -> mempty
-            PCNoConfig _ -> mempty
+            PCGlobalProject -> mempty
+            PCNoProject _ -> mempty
         flagEnabled name fl =
             fromMaybe (C.flagDefault fl) $
             Map.lookup (C.flagName fl) $

src/Stack/Runners.hs

@@ -14,7 +14,7 @@ module Stack.Runners
     , withEnvConfig
     , withDefaultEnvConfig
     , withConfig
-    , withNoProject
+    , withGlobalProject
     , withRunnerGlobal
     , ShouldReexec (..)
     ) where
@@ -35,11 +35,11 @@ import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
 import           System.Terminal (getTerminalWidth)
 
 -- | Ensure that no project settings are used when running 'withConfig'.
-withNoProject :: RIO Runner a -> RIO Runner a
-withNoProject inner = do
+withGlobalProject :: RIO Runner a -> RIO Runner a
+withGlobalProject inner = do
   oldSYL <- view stackYamlLocL
   case oldSYL of
-    SYLDefault -> local (set stackYamlLocL SYLNoProject) inner
+    SYLDefault -> local (set stackYamlLocL SYLGlobalProject) inner
     _ -> throwString "Cannot use this command with options which override the stack.yaml location"
 
 -- | Helper for 'withEnvConfig' which passes in some default arguments:

src/Stack/Script.hs

@@ -66,17 +66,17 @@ scriptCmd opts = do
       SYLOverride fp -> logError $
         "Ignoring override stack.yaml file for script command: " <>
         fromString (toFilePath fp)
-      SYLNoProject -> logError "Ignoring SYLNoProject for script command"
+      SYLGlobalProject -> logError "Ignoring SYLGlobalProject for script command"
       SYLDefault -> return ()
-      SYLNoConfig _ -> assert False (return ())
+      SYLNoProject _ -> assert False (return ())
 
     file <- resolveFile' $ soFile opts
     let scriptDir = parent file
         modifyGO go = go
             { globalConfigMonoid = (globalConfigMonoid go)
                 { configMonoidInstallGHC = FirstTrue $ Just True
                 }
-            , globalStackYaml = SYLNoConfig $ soScriptExtraDeps opts
+            , globalStackYaml = SYLNoProject $ soScriptExtraDeps opts
             }
 
     -- Optimization: if we're compiling, and the executable is newer