From a7f7baa3a90caff8f950459a55d0e8ececa2edea Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 17:46:37 +0300 Subject: [PATCH] Allow properly loading custom snapshots in scripts #3218 --- src/Stack/Config.hs | 53 ++++++++++++++++++++++----------------- src/Stack/ConfigCmd.hs | 2 +- src/Stack/Script.hs | 6 ++--- src/Stack/Snapshot.hs | 13 ++++++++-- src/Stack/Types/Config.hs | 4 ++- 5 files changed, 48 insertions(+), 30 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 74616130d2..1db1ff97e3 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -468,7 +468,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do config <- case mproject of - LCSNoConfig -> configNoLocalConfig stackRoot mresolver configArgs + LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs LCSProject project -> loadHelper $ Just project LCSNoProject -> loadHelper Nothing unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) @@ -488,7 +488,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do case mprojectRoot of LCSProject fp -> Just fp LCSNoProject -> Nothing - LCSNoConfig -> Nothing + LCSNoConfig _ -> Nothing } -- | Load the configuration, using current directory, environment variables, @@ -517,9 +517,14 @@ loadBuildConfig mproject mresolver mcompiler = do (project', stackYamlFP) <- case mproject of LCSProject (project, fp, _) -> do forM_ (projectUserMsg project) ($logWarn . T.pack) - return (project, fp) - LCSNoConfig -> do - p <- getEmptyProject + resolver <- + case mresolver of + Nothing -> return $ projectResolver project + Just aresolver -> + runRIO config $ makeConcreteResolver (Just (parent fp)) aresolver + return (project { projectResolver = resolver }, fp) + LCSNoConfig parentDir -> do + p <- getEmptyProject (Just parentDir) return (p, configUserConfigPath config) LCSNoProject -> do $logDebug "Run from outside a project, using implicit global project config" @@ -552,7 +557,7 @@ loadBuildConfig mproject mresolver mcompiler = do else do $logInfo ("Writing implicit global project config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." - p <- getEmptyProject + p <- getEmptyProject Nothing liftIO $ do S.writeFile dest' $ S.concat [ "# This is the implicit global project's config file, which is only used when\n" @@ -568,17 +573,11 @@ loadBuildConfig mproject mresolver mcompiler = do [ "This is the implicit global project, which is used only when 'stack' is run\n" , "outside of a real project.\n" ] return (p, dest) - resolver <- - case mresolver of - Nothing -> return $ projectResolver project' - Just aresolver -> - runRIO config $ makeConcreteResolver (Just (parent stackYamlFP)) aresolver let project = project' - { projectResolver = resolver - , projectCompiler = mcompiler <|> projectCompiler project' + { projectCompiler = mcompiler <|> projectCompiler project' } - sd0 <- runRIO config $ loadResolver resolver + sd0 <- runRIO config $ loadResolver $ projectResolver project let sd = maybe id setCompilerVersion (projectCompiler project) sd0 extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) @@ -596,14 +595,15 @@ loadBuildConfig mproject mresolver mcompiler = do case mproject of LCSNoProject -> True LCSProject _ -> False - LCSNoConfig -> False + LCSNoConfig _ -> False } where - getEmptyProject :: RIO Config Project - getEmptyProject = do + getEmptyProject :: Maybe (Path Abs Dir) -- ^ directory used for making concrete resolver + -> RIO Config Project + getEmptyProject mparentDir = do r <- case mresolver of Just aresolver -> do - r' <- makeConcreteResolver Nothing aresolver + r' <- makeConcreteResolver mparentDir aresolver $logInfo ("Using resolver: " <> resolverRawName r' <> " specified on command line") return r' Nothing -> do @@ -862,12 +862,13 @@ getProjectConfig SYLDefault = do if exists then return $ Just fp else return Nothing -getProjectConfig SYLNoConfig = return LCSNoConfig +getProjectConfig (SYLNoConfig parentDir) = return (LCSNoConfig parentDir) data LocalConfigStatus a = LCSNoProject | LCSProject a - | LCSNoConfig + | LCSNoConfig !(Path Abs Dir) + -- ^ parent directory for making a concrete resolving deriving (Show,Functor,Foldable,Traversable) -- | Find the project config file location, respecting environment variables @@ -888,9 +889,9 @@ loadProjectConfig mstackYaml = do LCSNoProject -> do $logDebug $ "No project config file found, using defaults." return LCSNoProject - LCSNoConfig -> do + LCSNoConfig mparentDir -> do $logDebug "Ignoring config files" - return LCSNoConfig + return (LCSNoConfig mparentDir) where load fp = do ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp @@ -943,7 +944,13 @@ getFakeConfigPath stackRoot ar = do case ar of ARResolver r -> return $ T.unpack $ resolverRawName r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar - asDir <- parseRelDir asString + -- 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 $(mkRelDir "script") asDir $(mkRelFile "config.yaml") ensureDir (parent full) return full diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 5f15d5ce9f..a6ad913bf3 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -61,7 +61,7 @@ cfgCmdSet go cmd = do case mstackYaml of LCSProject stackYaml -> return stackYaml LCSNoProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) - LCSNoConfig -> throwString "config command used when no local configuration available" + LCSNoConfig _ -> throwString "config command used when no local configuration available" 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/Script.hs b/src/Stack/Script.hs index edfbf53402..e747645cb1 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -30,11 +30,12 @@ import System.Process.Read -- | Run a Stack Script scriptCmd :: ScriptOpts -> GlobalOpts -> IO () scriptCmd opts go' = do + file <- resolveFile' $ soFile opts let go = go' { globalConfigMonoid = (globalConfigMonoid go') { configMonoidInstallGHC = First $ Just True } - , globalStackYaml = SYLNoConfig + , globalStackYaml = SYLNoConfig $ parent file } withBuildConfigAndLock go $ \lk -> do -- Some warnings in case the user somehow tries to set a @@ -46,7 +47,7 @@ scriptCmd opts go' = do SYLOverride fp -> $logError $ T.pack $ "Ignoring override stack.yaml file for script command: " ++ fp SYLDefault -> return () - SYLNoConfig -> assert False (return ()) + SYLNoConfig _ -> assert False (return ()) config <- view configL menv <- liftIO $ configEnvOverride config defaultEnvSettings @@ -100,7 +101,6 @@ scriptCmd opts go' = do SEInterpret -> exec menv ("run" ++ compilerExeName wc) (ghcArgs ++ soFile opts : soArgs opts) _ -> do - file <- resolveFile' $ soFile opts let dir = parent file -- use sinkProcessStdout to ensure a ProcessFailed -- exception is generated for better error messages diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs index d1a175045c..8470dea9cb 100644 --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -77,6 +77,7 @@ data SnapshotException | FilepathInCustomSnapshot !Text | NeedResolverOrCompiler !Text | MissingPackages !(Set PackageName) + | CustomResolverException !Text !(Either Request FilePath) !ParseException deriving Typeable instance Exception SnapshotException instance Show SnapshotException where @@ -123,6 +124,14 @@ instance Show SnapshotException where show (MissingPackages names) = "The following packages specified by flags or options are not found: " ++ unwords (map packageNameString (Set.toList names)) + show (CustomResolverException url loc e) = concat + [ "Unable to load custom resolver " + , T.unpack url + , " from location\n" + , show loc + , "\nException: " + , show e + ] -- | Convert a 'Resolver' into a 'SnapshotDef' loadResolver @@ -233,7 +242,7 @@ loadResolver (ResolverCompiler compiler) = return SnapshotDef , sdGlobalHints = Map.empty } loadResolver (ResolverCustom url loc) = do - $logDebug $ "Loading " <> url <> " build plan" + $logDebug $ "Loading " <> url <> " build plan from " <> T.pack (show loc) case loc of Left req -> download' req >>= load . toFilePath Right fp -> load fp @@ -255,7 +264,7 @@ loadResolver (ResolverCustom url loc) = do load fp = do WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- liftIO (decodeFileEither fp) >>= either - throwM + (throwM . CustomResolverException url loc) (either (throwM . AesonException) return . parseEither parseCustom) logJSONWarnings (T.unpack url) warnings diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 664904e485..c60b585c2d 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -444,7 +444,9 @@ data GlobalOpts = GlobalOpts data StackYamlLoc filepath = SYLDefault | SYLOverride !filepath - | SYLNoConfig + | SYLNoConfig !(Path Abs Dir) + -- ^ FilePath is the directory containing the script file, used + -- for resolving custom snapshot files. deriving (Show,Functor,Foldable,Traversable) -- | Parsed global command-line options monoid.