Rename NoConfig to NoProject

This also changes the behavior: we _do_ load up the user config file, just no project config file. * Fixes #3705 * Fixes #3887 * Fixes #4699
commercialhaskell · Apr 5, 2019 · 98bb45d · 98bb45d
1 parent b7eb509
commit 98bb45d
Show file tree

Hide file tree

Showing 8 changed files with 45 additions and 90 deletions.
diff --git a/ChangeLog.md b/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:
 

diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs
@@ -479,4 +479,4 @@ parseTargets needTargets haddockDeps boptscli smActual = do
       case configProject $ bcConfig bconfig of
         PCProject _ -> False
         PCGlobalProject -> True
-        PCNoConfig _ -> False
+        PCNoProject _ -> False
diff --git a/src/Stack/Config.hs b/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,41 +172,18 @@ 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"
@@ -217,7 +192,12 @@ configFromConfigMonoid
            case configProject of
              PCProject pair -> Just pair
              PCGlobalProject -> Nothing
-             PCNoConfig _deps -> 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
@@ -411,31 +391,25 @@ loadConfig inner = do
           case mproject of
             PCProject (proj, fp, cm) -> (PCProject (proj, fp), (cm:))
             PCGlobalProject -> (PCGlobalProject, 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
-
+            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
-          PCGlobalProject -> loadHelper
 
     withConfig $ \config -> do
       unless (mkVersion' Meta.version `withinRange` configRequireStackVersion config)
@@ -469,8 +443,11 @@ 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)
       PCGlobalProject -> do
             logDebug "Run from outside a project, using implicit global project config"
@@ -779,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
@@ -799,9 +776,9 @@ loadProjectConfig mstackYaml = do
         PCGlobalProject -> do
             logDebug "No project config file found, using defaults."
             return PCGlobalProject
-        PCNoConfig extraDeps -> do
+        PCNoProject extraDeps -> do
             logDebug "Ignoring config files"
-            return $ PCNoConfig extraDeps
+            return $ PCNoProject extraDeps
   where
     load fp = do
         iopc <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
@@ -843,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"))
 

diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs
@@ -67,7 +67,7 @@ cfgCmdSet cmd = do
                      case mstackYaml of
                          PCProject stackYaml -> return stackYaml
                          PCGlobalProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
-                         PCNoConfig _extraDeps -> throwString "config command used when no local configuration available"
+                         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) <-

diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs
@@ -27,7 +27,7 @@ freeze (FreezeOpts mode) = do
   case mproject of
     PCProject (p, _) -> doFreeze p mode
     PCGlobalProject -> warn
-    PCNoConfig _ -> warn
+    PCNoProject _ -> warn
 
 doFreeze ::
        (HasProcessContext env, HasLogFunc env, HasPantryConfig env)

diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs
@@ -86,7 +86,7 @@ flagCompleter = buildConfigCompleter $ \input -> do
           case configProject (bcConfig bconfig) of
             PCProject (p, _) -> projectFlags p
             PCGlobalProject -> mempty
-            PCNoConfig _ -> mempty
+            PCNoProject _ -> mempty
         flagEnabled name fl =
             fromMaybe (C.flagDefault fl) $
             Map.lookup (C.flagName fl) $

diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs
@@ -68,15 +68,15 @@ scriptCmd opts = do
         fromString (toFilePath fp)
       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

diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -364,7 +364,7 @@ configProjectRoot c =
   case configProject c of
     PCProject (_, fp) -> Just $ parent fp
     PCGlobalProject -> Nothing
-    PCNoConfig _deps -> Nothing
+    PCNoProject _deps -> Nothing
 
 -- | Which packages do ghc-options on the command line apply to?
 data ApplyGhcOptions = AGOTargets -- ^ all local targets
@@ -463,8 +463,9 @@ data StackYamlLoc
     -- ^ Use the standard parent-directory-checking logic
     | SYLOverride !(Path Abs File)
     -- ^ Use a specific stack.yaml file provided
-    | SYLNoConfig ![PackageIdentifierRevision]
-    -- ^ Extra dependencies included in the script command line.
+    | SYLNoProject ![PackageIdentifierRevision]
+    -- ^ Do not load up a project, just user configuration. Include
+    -- the given extra dependencies with the resolver.
     | SYLGlobalProject
     -- ^ Do not look for a project configuration, and use the implicit global.
     deriving Show
@@ -481,9 +482,8 @@ data ProjectConfig a
     | PCGlobalProject
     -- ^ No project was found when using 'SYLDefault'. Instead, use
     -- the implicit global.
-    | PCNoConfig ![PackageIdentifierRevision]
-    -- ^ Use a no config run, which explicitly ignores any local
-    -- configuration values. This comes from 'SYLNoConfig'.
+    | PCNoProject ![PackageIdentifierRevision]
+    -- ^ Use a no project run. This comes from 'SYLNoProject'.
 
 -- | Parsed global command-line options monoid.
 data GlobalOptsMonoid = GlobalOptsMonoid
@@ -1037,8 +1037,7 @@ data ConfigException
   | UserDoesn'tOwnDirectory (Path Abs Dir)
   | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
   | NixRequiresSystemGhc
-  | NoResolverWhenUsingNoLocalConfig
-  | InvalidResolverForNoLocalConfig String
+  | NoResolverWhenUsingNoProject
   | DuplicateLocalPackageNames ![(PackageName, [PackageLocation])]
   deriving Typeable
 instance Show ConfigException where
@@ -1142,8 +1141,7 @@ instance Show ConfigException where
         , configMonoidSystemGHCName
         , "' or disable the Nix integration."
         ]
-    show NoResolverWhenUsingNoLocalConfig = "When using the script command, you must provide a resolver argument"
-    show (InvalidResolverForNoLocalConfig ar) = "The script command requires a specific resolver, you provided " ++ ar
+    show NoResolverWhenUsingNoProject = "When using the script command, you must provide a resolver argument"
     show (DuplicateLocalPackageNames pairs) = concat
         $ "The same package name is used in multiple local packages\n"
         : map go pairs