From 65238e2b1f7afc9f51c0685f08107be72a0927a6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 9 Feb 2017 15:38:48 +0200 Subject: [PATCH] Script command #2805 This adds a basic script command. Most of the work involved has to do with preventing config files from being loaded. Originally we planned on creating an alternative set of config types for with and without a local config. That turned out to be prohibitively invasive. Instead, we now just create a dummy config file instead ~/.stack/script/lts-x.y (or /nightly-...). While this addresses reproducibility, it doesn't help with the speed concerns: script is now about 100ms faster than runghc on my system for the case where --package is provided, but it's still over a second for Hello World. The slowdown is inherent right now in checking if the relevant packages are installed. It would be nice to figure out a way to optimize the package check. Also, this should include some integration tests. It should be a simple matter of a test that includes a bogus stack.yaml and proving that stack script ignores it. --- ChangeLog.md | 9 ++ doc/GUIDE.md | 116 +++++++++++-------- src/Stack/Build.hs | 12 ++ src/Stack/Config.hs | 184 +++++++++++++++++++++--------- src/Stack/ConfigCmd.hs | 7 +- src/Stack/Options/GlobalParser.hs | 2 +- src/Stack/Runners.hs | 10 +- src/Stack/Setup.hs | 2 +- src/Stack/Types/Build.hs | 4 + src/Stack/Types/Config.hs | 19 ++- src/Stack/Types/Config.hs-boot | 2 + src/Stack/Upgrade.hs | 2 +- src/main/Main.hs | 82 ++++++++++++- src/test/Stack/BuildPlanSpec.hs | 2 +- src/test/Stack/ConfigSpec.hs | 2 +- src/test/Stack/NixSpec.hs | 2 +- stack.cabal | 2 + 17 files changed, 348 insertions(+), 111 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 8ca2dbe3c5..d25f2f1acd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,6 +6,15 @@ Release notes: Major changes: +* A new command, `script`, has been added, intended to make the script + interpreter workflow more reliable, easier to use, and more + efficient. This command forces the user to provide a `--resolver` + value, ignores all config files for more reproducible results, and + optimizes the existing package check to make the common case of all + packages already being present much faster. This mode does require + that all packages be present in a snapshot, however. + [#2805](https://github.com/commercialhaskell/stack/issues/2805) + Behavior changes: * The default package metadata backend has been changed from Git to diff --git a/doc/GUIDE.md b/doc/GUIDE.md index 1a58a5351a..cd5bad0dbd 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1646,23 +1646,17 @@ running the file. An example will be easiest to understand: ``` -michael@d30748af6d3d:~$ cat turtle.hs +michael@d30748af6d3d:~$ cat turtle-example.hs #!/usr/bin/env stack --- stack --resolver lts-3.2 --install-ghc runghc --package turtle +-- stack --resolver lts-6.25 script --package turtle {-# LANGUAGE OverloadedStrings #-} import Turtle main = echo "Hello World!" -michael@d30748af6d3d:~$ chmod +x turtle.hs -michael@d30748af6d3d:~$ ./turtle.hs -Run from outside a project, using implicit global project config -Using resolver: lts-3.2 specified on command line -hashable-1.2.3.3: configure -# installs some more dependencies -Completed all 22 actions. +michael@d30748af6d3d:~$ chmod +x turtle-example.hs +michael@d30748af6d3d:~$ ./turtle-example.hs +Completed 5 action(s). Hello World! -michael@d30748af6d3d:~$ ./turtle.hs -Run from outside a project, using implicit global project config -Using resolver: lts-3.2 specified on command line +michael@d30748af6d3d:~$ ./turtle-example.hs Hello World! ``` @@ -1680,11 +1674,30 @@ ensure the turtle package is available. If you're on Windows: you can run `stack turtle.hs` instead of `./turtle.hs`. The shebang line is not required in that case. +### Using multiple packages + +You can also specify multiple packages, either with multiple `--package` +arguments, or by providing a comma or space separated list. For example: + +``` +#!/usr/bin/env stack +{- stack + script + --resolver lts-6.25 + --package turtle + --package "stm async" + --package http-client,http-conduit +-} +``` + ### Stack configuration for scripts -If the current working directory is inside a project then that project's stack -configuration is effective when running the script. Otherwise the script uses -the global project configuration specified in +With the `script` command, all Stack configuration files are ignored to provide a +completely reliable script running experience. However, see the example below +with `runghc` for an approach to scripts which will respect your configuration +files. When using `runghc`, if the current working directory is inside a +project then that project's stack configuration is effective when running the +script. Otherwise the script uses the global project configuration specified in `~/.stack/global-project/stack.yaml`. ### Specifying interpreter options @@ -1703,50 +1716,61 @@ separating the stack options and ghc options with a `--`. Here is an example of a multi line block comment with ghc options: ``` - #!/usr/bin/env stack - {- stack - --resolver lts-3.2 - --install-ghc - runghc - --package turtle - -- - -hide-all-packages - -} +#!/usr/bin/env stack +{- stack + script + --resolver lts-6.25 + --package turtle + -- + +RTS -s -RTS +-} ``` ### Writing independent and reliable scripts -Independent means that the script is independent of any prior deployment -specific configuration. If required, the script will install everything it -needs automatically on any machine that it runs on. To make a script always -work irrespective of any specific environment configuration you can do the -following: +With the release of Stack 1.2.1, there is a new command, `script`, which will +automatically: + +* Install GHC and libraries if missing +* Require that all packages used be explicitly stated on the command line + +This ensures that your scripts are _independent_ of any prior deployment +specific configuration, and are _reliable_ by using exactly the same version of +all packages every time it runs so that the script does not break by +accidentally using incompatible package versions. + +In previous versions of Stack, the `runghc` command was used for scripts +instead. In order to achieve the same effect with the `runghc` command, you can +do the following: 1. Use the `--install-ghc` option to install the compiler automatically 2. Explicitly specify all packages required by the script using the `--package` option. Use `-hide-all-packages` ghc option to force explicit specification of all packages. +3. Use the `--resolver` Stack option to ensure a specific GHC version and + package set is used. -Reliable means the script will use exactly the same version of all packages -every time it runs so that the script does not break by accidentally using -incompatible package versions. To achieve that use an explicit `--resolver` -stack option. - -Here is an interpreter comment for a completely self-contained and reproducible -version of our toy example: -``` - #!/usr/bin/env stack - {- stack - --resolver lts-3.2 - --install-ghc - runghc - --package base - --package turtle - -- - -hide-all-packages +Even with this configuration, it is still possible for configuration +files to impact `stack runghc`, which is why `stack script` is strongly +recommended in general. For those curious, here is an example with `runghc`: + +``` +#!/usr/bin/env stack +{- stack + --resolver lts-6.25 + --install-ghc + runghc + --package base + --package turtle + -- + -hide-all-packages -} ``` +The `runghc` command is still very useful, especially when you're working on a +project and want to access the package databases and configurations used by +that project. See the next section for more information on configuration files. + ## Finding project configs, and the implicit global Whenever you run something with stack, it needs a stack.yaml project file. The diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 0e13de25eb..8c05d0a69e 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -120,6 +120,11 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do plan <- withLoadPackage menv $ \loadPackage -> constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap + allowLocals <- view $ configL.to configAllowLocals + unless allowLocals $ case justLocals plan of + [] -> return () + localsIdents -> throwM $ LocalPackagesPresent localsIdents + -- If our work to do is all local, let someone else have a turn with the snapshot. -- They won't damage what's already in there. case (mbuildLk, allLocal plan) of @@ -155,6 +160,13 @@ allLocal = Map.elems . planTasks +justLocals :: Plan -> [PackageIdentifier] +justLocals = + map taskProvides . + filter ((== Local) . taskLocation) . + Map.elems . + planTasks + checkCabalVersion :: (StackM env m, HasEnvConfig env) => m () checkCabalVersion = do allowNewer <- view $ configL.to configAllowNewer diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 3fce96e6e7..fff65f3b40 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -1,5 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -39,6 +42,7 @@ module Stack.Config ,getInNixShell ,defaultConfigYaml ,getProjectConfig + ,LocalConfigStatus(..) ) where import qualified Codec.Archive.Tar as Tar @@ -216,16 +220,38 @@ getLatestResolver = do snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts return (ResolverSnapshot snap) +-- | Create a 'Config' value when we're not using any local +-- configuration files (e.g., the script command) +configNoLocalConfig + :: (MonadLogger m, MonadIO m, MonadCatch m) + => Path Abs Dir -- ^ stack root + -> Maybe AbstractResolver + -> ConfigMonoid + -> m Config +configNoLocalConfig _ Nothing _ = throwM NoResolverWhenUsingNoLocalConfig +configNoLocalConfig stackRoot (Just resolver) configMonoid = do + userConfigPath <- getFakeConfigPath stackRoot resolver + configFromConfigMonoid + stackRoot + userConfigPath + False + (Just resolver) + Nothing -- project + configMonoid + -- Interprets ConfigMonoid options. configFromConfigMonoid :: (MonadLogger m, MonadIO m, MonadCatch m) => 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 -> Maybe (Project, Path Abs File) -> ConfigMonoid -> m Config -configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject ConfigMonoid{..} = do +configFromConfigMonoid + configStackRoot configUserConfigPath configAllowLocals mresolver + mproject ConfigMonoid{..} = do let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir -- This code is to handle the deprecation of latest-snapshot-url configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of @@ -413,24 +439,36 @@ loadConfigMaybeProject -- ^ Config monoid from parsed command-line arguments -> Maybe AbstractResolver -- ^ Override resolver - -> Maybe (Project, Path Abs File, ConfigMonoid) + -> LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -- ^ Project config to use, if any -> m (LoadConfig m) loadConfigMaybeProject configArgs mresolver mproject = do (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs - userConfigPath <- getDefaultUserConfigPath stackRoot - extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadConfigYaml - 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 mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject - config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $ + + let loadHelper mproject' = do + userConfigPath <- getDefaultUserConfigPath stackRoot + extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadConfigYaml + 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 + + configFromConfigMonoid + stackRoot + userConfigPath + True -- allow locals + mresolver + (fmap (\(x, y, _) -> (x, y)) mproject') + $ mconcat $ configArgs + : maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs + + config <- case mproject of - Nothing -> configArgs : extraConfigs - Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs + LCSNoConfig -> configNoLocalConfig stackRoot mresolver configArgs + LCSProject project -> loadHelper $ Just project + LCSNoProject -> loadHelper Nothing unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) @@ -444,7 +482,11 @@ loadConfigMaybeProject configArgs mresolver mproject = do return LoadConfig { lcConfig = config , lcLoadBuildConfig = loadBuildConfig mproject config mresolver - , lcProjectRoot = mprojectRoot + , lcProjectRoot = + case mprojectRoot of + LCSProject fp -> Just fp + LCSNoProject -> Nothing + LCSNoConfig -> Nothing } -- | Load the configuration, using current directory, environment variables, @@ -455,7 +497,7 @@ loadConfig :: StackM env m -- ^ Config monoid from parsed command-line arguments -> Maybe AbstractResolver -- ^ Override resolver - -> Maybe (Path Abs File) + -> StackYamlLoc (Path Abs File) -- ^ Override stack.yaml -> m (LoadConfig m) loadConfig configArgs mresolver mstackYaml = @@ -464,20 +506,22 @@ loadConfig configArgs mresolver mstackYaml = -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. loadBuildConfig :: StackM env m - => Maybe (Project, Path Abs File, ConfigMonoid) + => LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -> Config -> Maybe AbstractResolver -- override resolver -> Maybe CompilerVersion -- override compiler -> m BuildConfig loadBuildConfig mproject config mresolver mcompiler = do env <- ask - let miniConfig = loadMiniConfig config (project', stackYamlFP) <- case mproject of - Just (project, fp, _) -> do + LCSProject (project, fp, _) -> do forM_ (projectUserMsg project) ($logWarn . T.pack) return (project, fp) - Nothing -> do + LCSNoConfig -> do + p <- getEmptyProject + return (p, configUserConfigPath config) + LCSNoProject -> do $logDebug "Run from outside a project, using implicit global project config" destDir <- getImplicitGlobalProjectDir config let dest :: Path Abs File @@ -506,26 +550,9 @@ loadBuildConfig mproject config mresolver mcompiler = do " specified on command line") return (project, dest) else do - r <- case mresolver of - Just aresolver -> do - r' <- runReaderT (makeConcreteResolver aresolver) miniConfig - $logInfo ("Using resolver: " <> resolverName r' <> " specified on command line") - return r' - Nothing -> do - r'' <- runReaderT getLatestResolver miniConfig - $logInfo ("Using latest snapshot resolver: " <> resolverName r'') - return r'' $logInfo ("Writing implicit global project config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." - let p = Project - { projectUserMsg = Nothing - , projectPackages = mempty - , projectExtraDeps = mempty - , projectFlags = mempty - , projectResolver = r - , projectCompiler = Nothing - , projectExtraPackageDBs = [] - } + p <- getEmptyProject liftIO $ do S.writeFile dest' $ S.concat [ "# This is the implicit global project's config file, which is only used when\n" @@ -572,9 +599,35 @@ loadBuildConfig mproject config mresolver mcompiler = do , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project - , bcImplicitGlobal = isNothing mproject + , bcImplicitGlobal = + case mproject of + LCSNoProject -> True + LCSProject _ -> False + LCSNoConfig -> False } } + where + miniConfig = loadMiniConfig config + + getEmptyProject = do + r <- case mresolver of + Just aresolver -> do + r' <- runReaderT (makeConcreteResolver aresolver) miniConfig + $logInfo ("Using resolver: " <> resolverName r' <> " specified on command line") + return r' + Nothing -> do + r'' <- runReaderT getLatestResolver miniConfig + $logInfo ("Using latest snapshot resolver: " <> resolverName r'') + return r'' + return Project + { projectUserMsg = Nothing + , projectPackages = mempty + , projectExtraDeps = mempty + , projectFlags = mempty + , projectResolver = r + , projectCompiler = Nothing + , projectExtraPackageDBs = [] + } -- | Get packages from EnvConfig, downloading and cloning as necessary. -- If the packages have already been downloaded, this uses a cached value ( @@ -865,19 +918,19 @@ loadYaml path = do -- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) - => Maybe (Path Abs File) + => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (Maybe (Path Abs File)) -getProjectConfig (Just stackYaml) = return $ Just stackYaml -getProjectConfig Nothing = do + -> m (LocalConfigStatus (Path Abs File)) +getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml +getProjectConfig SYLDefault = do env <- liftIO getEnvironment case lookup "STACK_YAML" env of Just fp -> do $logInfo "Getting project config file from STACK_YAML environment" - liftM Just $ resolveFile' fp + liftM LCSProject $ resolveFile' fp Nothing -> do currDir <- getCurrentDir - findInParents getStackDotYaml currDir + maybe LCSNoProject LCSProject <$> findInParents getStackDotYaml currDir where getStackDotYaml dir = do let fp = dir stackDotYaml @@ -887,29 +940,39 @@ getProjectConfig Nothing = do if exists then return $ Just fp else return Nothing +getProjectConfig SYLNoConfig = return LCSNoConfig + +data LocalConfigStatus a + = LCSNoProject + | LCSProject a + | LCSNoConfig + deriving (Show,Functor,Foldable,Traversable) -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) - => Maybe (Path Abs File) + => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (Maybe (Project, Path Abs File, ConfigMonoid)) + -> m (LocalConfigStatus (Project, Path Abs File, ConfigMonoid)) loadProjectConfig mstackYaml = do mfp <- getProjectConfig mstackYaml case mfp of - Just fp -> do + LCSProject fp -> do currDir <- getCurrentDir $logDebug $ "Loading project config file " <> T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp)) - load fp - Nothing -> do + LCSProject <$> load fp + LCSNoProject -> do $logDebug $ "No project config file found, using defaults." - return Nothing + return LCSNoProject + LCSNoConfig -> do + $logDebug "Ignoring config files" + return LCSNoConfig where load fp = do ProjectAndConfigMonoid project config <- loadConfigYaml fp - return $ Just (project, fp, config) + return (project, fp, config) -- | Get the location of the default stack configuration file. -- If a file already exists at the deprecated location, its location is returned. @@ -946,6 +1009,23 @@ 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 -> return $ T.unpack $ resolverName r + _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar + asDir <- parseRelDir asString + let full = stackRoot $(mkRelDir "script") asDir $(mkRelFile "config.yaml") + 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 index 5c1e6258a5..d5cf5bcb42 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -30,7 +30,7 @@ import Path import Path.IO import Prelude -- Silence redundant import warnings import Stack.BuildPlan -import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir) +import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir, LocalConfigStatus(..)) import Stack.Constants import Stack.Types.Config import Stack.Types.Resolver @@ -67,8 +67,9 @@ cfgCmdSet go cmd = do mstackYamlOption <- forM (globalStackYaml go) resolveFile' mstackYaml <- getProjectConfig mstackYamlOption case mstackYaml of - Just stackYaml -> return stackYaml - Nothing -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) + LCSProject stackYaml -> return stackYaml + LCSNoProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) + LCSNoConfig -> error "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/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs index 883fe62295..85fb8f0e42 100644 --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -61,7 +61,7 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts , globalCompiler = getFirst globalMonoidCompiler , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal , globalColorWhen = fromFirst ColorAuto globalMonoidColorWhen - , globalStackYaml = getFirst globalMonoidStackYaml } + , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml } initOptsParser :: Parser InitOpts initOptsParser = diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index ec5f764667..e9f44f43a9 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -108,7 +108,10 @@ withGlobalConfigAndLock -> IO () withGlobalConfigAndLock go@GlobalOpts{..} inner = do lc <- runStackTGlobal () go $ - loadConfigMaybeProject globalConfigMonoid Nothing Nothing + loadConfigMaybeProject + globalConfigMonoid + Nothing + LCSNoProject withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> runStackTGlobal (lcConfig lc) go inner @@ -210,7 +213,10 @@ withMiniConfigAndLock go@GlobalOpts{..} inner = do miniConfig <- runStackTGlobal () go $ (loadMiniConfig . lcConfig) <$> - loadConfigMaybeProject globalConfigMonoid globalResolver Nothing + loadConfigMaybeProject + globalConfigMonoid + globalResolver + LCSNoProject runStackTGlobal miniConfig go inner -- | Unlock a lock file, if the value is Just diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 63190b955e..23b8286018 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1199,7 +1199,7 @@ loadGhcjsEnvConfig stackYaml binPath = runInnerStackT () $ do , configMonoidLocalBinPath = First (Just (toFilePath binPath)) }) Nothing - (Just stackYaml) + (SYLOverride stackYaml) bconfig <- lcLoadBuildConfig lc Nothing runInnerStackT bconfig $ setupEnv Nothing diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 0610b841bf..41df4c4fe5 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -135,6 +135,7 @@ data StackBuildException | SomeTargetsNotBuildable [(PackageName, NamedComponent)] | TestSuiteExeMissing Bool String String String | CabalCopyFailed Bool String + | LocalPackagesPresent [PackageIdentifier] deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -338,6 +339,9 @@ instance Show StackBuildException where , "\n" ] show (ConstructPlanFailed msg) = msg + show (LocalPackagesPresent locals) = unlines + $ "Local packages are not allowed when using the script command. Packages found:" + : map (\ident -> "- " ++ packageIdentifierString ident) locals missingExeError :: Bool -> String -> String missingExeError isSimpleBuildType msg = diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 10c4f457db..17a1fe774b 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -2,7 +2,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -74,6 +77,7 @@ module Stack.Types.Config -- ** GlobalOpts & GlobalOptsMonoid ,GlobalOpts(..) ,GlobalOptsMonoid(..) + ,StackYamlLoc(..) ,defaultLogLevel -- ** LoadConfig ,LoadConfig(..) @@ -369,6 +373,9 @@ data Config = ,configMaybeProject :: !(Maybe (Project, Path Abs File)) -- ^ 'Just' when a local project can be found, 'Nothing' when stack must -- fall back on the implicit global project. + ,configAllowLocals :: !Bool + -- ^ Are we allowed to build local packages? The script + -- command disallows this. } -- | Which packages do ghc-options on the command line apply to? @@ -455,9 +462,15 @@ data GlobalOpts = GlobalOpts , globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors - , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml + , globalStackYaml :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml } deriving (Show) +data StackYamlLoc filepath + = SYLDefault + | SYLOverride !filepath + | SYLNoConfig + deriving (Show,Functor,Foldable,Traversable) + -- | Parsed global command-line options monoid. data GlobalOptsMonoid = GlobalOptsMonoid { globalMonoidReExecVersion :: !(First String) -- ^ Expected re-exec in container version @@ -1014,6 +1027,8 @@ data ConfigException | FailedToCloneRepo String | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC | NixRequiresSystemGhc + | NoResolverWhenUsingNoLocalConfig + | InvalidResolverForNoLocalConfig String deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1132,6 +1147,8 @@ 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 instance Exception ConfigException showOptions :: WhichSolverCmd -> SuggestSolver -> String diff --git a/src/Stack/Types/Config.hs-boot b/src/Stack/Types/Config.hs-boot index 1779434e50..e842c0de0d 100644 --- a/src/Stack/Types/Config.hs-boot +++ b/src/Stack/Types/Config.hs-boot @@ -32,4 +32,6 @@ data ConfigException | FailedToCloneRepo String | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC | NixRequiresSystemGhc + | NoResolverWhenUsingNoLocalConfig + | InvalidResolverForNoLocalConfig String instance Exception ConfigException diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index b16e1ec5b7..0ee80983b5 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -239,7 +239,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = lc <- loadConfig gConfigMonoid mresolver - (Just $ dir $(mkRelFile "stack.yaml")) + (SYLOverride $ dir $(mkRelFile "stack.yaml")) bconfig <- lcLoadBuildConfig lc Nothing envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <> diff --git a/src/main/Main.hs b/src/main/Main.hs index 3e17eaf5fe..a56e4a01af 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -24,11 +24,15 @@ import Control.Monad.Trans.Either (EitherT) import Control.Monad.Writer.Lazy (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import qualified Data.Conduit.List as CL import Data.List +import Data.List.Split (splitWhen) import qualified Data.Map as Map import Data.Maybe import Data.Monoid +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Traversable @@ -64,7 +68,7 @@ import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot import Stack.Exec -import Stack.GhcPkg (findGhcPkgField) +import Stack.GhcPkg (findGhcPkgField, ghcPkgExeName) import qualified Stack.Nix as Nix import Stack.Fetch import Stack.FileWatch @@ -98,6 +102,7 @@ import Stack.Types.Config import Stack.Types.Compiler import Stack.Types.Resolver import Stack.Types.Nix +import Stack.Types.PackageName (parsePackageNameFromString) import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload @@ -357,6 +362,10 @@ commandLineHandler progName isInterpreter = complicatedOptions "Run runghc (alias for 'runghc')" execCmd (execOptsParser $ Just ExecRunGhc) + addCommand' "script" + "Run a Stack Script" + scriptCmd + scriptOptsParser unless isInterpreter (do addCommand' "eval" @@ -791,6 +800,77 @@ execCmd ExecOpts {..} go@GlobalOpts{..} = pkgopts <- getPkgOpts menv wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) +scriptOptsParser :: Parser ([String], [String]) +scriptOptsParser = (,) + <$> many (strOption (long "package" <> help "Additional packages that must be installed")) + <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) + +-- | Run a Stack Script +scriptCmd :: ([String], [String]) -> GlobalOpts -> IO () +scriptCmd (packages', args') go' = do + let go = go' + { globalConfigMonoid = (globalConfigMonoid go') + { configMonoidInstallGHC = First $ Just True + } + , globalStackYaml = SYLNoConfig + } + withBuildConfigAndLock go $ \lk -> do + -- Some warnings in case the user somehow tries to set a + -- stack.yaml location + case globalStackYaml go' of + SYLOverride fp -> $logWarn $ T.pack + $ "Ignoring override stack.yaml file for script command: " ++ fp + SYLDefault -> return () + SYLNoConfig -> assert False (return ()) + + config <- view configL + menv <- liftIO $ configEnvOverride config defaultEnvSettings + wc <- view $ actualCompilerVersionL.whichCompilerL + + let targets = concatMap wordsComma packages' + targetsSet = Set.fromList targets + + -- Ensure only package names are provided. We do not allow + -- overriding packages in a snapshot. + mapM_ parsePackageNameFromString targets + + unless (null targets) $ do + -- Optimization: use the relatively cheap ghc-pkg list + -- --simple-output to check which packages are installed + -- already. If all needed packages are available, we can + -- skip the (rather expensive) build call below. + bss <- sinkProcessStdout + Nothing menv (ghcPkgExeName wc) + ["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy? + let installed = Set.fromList + $ map toPackageName + $ words + $ S8.unpack + $ S8.concat bss + if Set.null $ Set.difference targetsSet installed + then $logDebug "All packages already installed" + else do + $logDebug "Missing packages, performing installation" + Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + { boptsCLITargets = map T.pack targets + } + + let args = concat + [ ["-hide-all-packages"] + , map (\x -> "-package" ++ x) + $ Set.toList + $ Set.insert "base" targetsSet + , args' + ] + let cmd = "run" ++ compilerExeName wc + munlockFile lk -- Unlock before transferring control away. + exec menv cmd args + where + toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse + + -- Like words, but splits on both commas and spaces + wordsComma = splitWhen (\c -> c == ' ' || c == ',') + -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs index beccaa9dba..a916baad7e 100644 --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -33,7 +33,7 @@ main = hspec spec spec :: Spec spec = beforeAll setup $ do let logLevel = LevelDebug - let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing Nothing) + let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing SYLDefault) let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False let inTempDir action = do currentDirectory <- getCurrentDirectory diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index d217999479..fdfa579c23 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -80,7 +80,7 @@ spec = beforeAll setup $ do bracket_ setVar resetVar action describe "loadConfig" $ do - let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing Nothing) + let loadConfig' = runStackT () logLevel True False ColorAuto False (loadConfig mempty Nothing SYLDefault) let loadBuildConfigRest = runStackT () logLevel True False ColorAuto False -- TODO(danburton): make sure parent dirs also don't have config file it "works even if no config file exists" $ example $ do diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs index 3930bf1d1c..5258ff1a58 100644 --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -47,7 +47,7 @@ setup = unsetEnv "STACK_YAML" spec :: Spec spec = beforeAll setup $ do - let loadConfig' cmdLineArgs = runStackT () LevelDebug True False ColorAuto False (loadConfig cmdLineArgs Nothing Nothing) + let loadConfig' cmdLineArgs = runStackT () LevelDebug True False ColorAuto False (loadConfig cmdLineArgs Nothing SYLDefault) inTempDir test = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do diff --git a/stack.cabal b/stack.cabal index 667233cb21..bb0c9bed6a 100644 --- a/stack.cabal +++ b/stack.cabal @@ -294,6 +294,7 @@ executable stack build-depends: Cabal >= 1.18.1.5 && < 1.25 , base >=4.7 && < 5 , bytestring >= 0.10.4.0 + , conduit , containers >= 0.5.5.1 , directory >= 1.2.1.0 , either @@ -310,6 +311,7 @@ executable stack , optparse-applicative >= 0.13 && < 0.14 , path , path-io >= 1.1.0 && < 2.0.0 + , split , stack , text >= 1.2.0.4 , transformers >= 0.3.0.0 && < 0.6