diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,119 @@ # Changelog +## 1.4.0 + +Release notes: + +* Docker images: + [fpco/stack-full](https://hub.docker.com/r/fpco/stack-full/) and + [fpco/stack-run](https://hub.docker.com/r/fpco/stack-run/) + are no longer being built for LTS 8.0 and above. + [fpco/stack-build](https://hub.docker.com/r/fpco/stack-build/) + images continue to be built with a + [simplified process](https://github.com/commercialhaskell/stack/tree/master/etc/dockerfiles/stack-build). + [#624](https://github.com/commercialhaskell/stack/issues/624) + +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 + the 01-index.tar.gz file, from the hackage-security project. This is + intended to address some download speed issues from Github for + people in certain geographic regions. There is now full support for + checking out specific cabal file revisions from downloaded tarballs + as well. If you manually specify a package index with only a Git + URL, Git will still be used. See + [#2780](https://github.com/commercialhaskell/stack/issues/2780) +* When you provide the `--resolver` argument to the `stack unpack` + command, any packages passed in by name only will be looked up in + the given snapshot instead of taking the latest version. For + example, `stack --resolver lts-7.14 unpack mtl` will get version + 2.2.1 of `mtl`, regardless of the latest version available in the + package indices. This will also force the same cabal file revision + to be used as is specified in the snapshot. + + Unpacking via a package identifier (e.g. `stack --resolver lts-7.14 + unpack mtl-2.2.1`) will ignore any settings in the snapshot and take + the most recent revision. + + For backwards compatibility with tools relying on the presence of a + `00-index.tar`, Stack will copy the `01-index.tar` file to + `00-index.tar`. Note, however, that these files are different; most + importantly, 00-index contains only the newest revisions of cabal + files, while 01-index contains all versions. You may still need to + update your tooling. +* Passing `--(no-)nix-*` options now no longer implies `--nix`, except for + `--nix-pure`, so that the user preference whether or not to use Nix is + honored even in the presence of options that change the Nix behavior. + +Other enhancements: + +* Internal cleanup: configuration types are now based much more on lenses +* `stack build` and related commands now allow the user to disable debug symbol stripping + with new `--no-strip`, `--no-library-stripping`, and `--no-executable-shipping` flags, + closing [#877](https://github.com/commercialhaskell/stack/issues/877). + Also turned error message for missing targets more readable ([#2384](https://github.com/commercialhaskell/stack/issues/2384)) +* `stack haddock` now shows index.html paths when documentation is already up to + date. Resolved [#781](https://github.com/commercialhaskell/stack/issues/781) +* Respects the `custom-setup` field introduced in Cabal 1.24. This + supercedes any `explicit-setup-deps` settings in your `stack.yaml` + and trusts the package's `.cabal` file to explicitly state all its + dependencies. +* If system package installation fails, `get-stack.sh` will fail as well. Also + shows warning suggesting to run `apt-get update` or similar, depending on the + OS. + ([#2898](https://github.com/commercialhaskell/stack/issues/2898)) +* When `stack ghci` is run with a config with no packages (e.g. global project), + it will now look for source files in the current work dir. + ([#2878](https://github.com/commercialhaskell/stack/issues/2878)) +* Bump to hpack 0.17.0 to allow `custom-setup` and `!include "..."` in `package.yaml`. +* The script interpreter will now output error logging. In particular, + this means it will output info about plan construction errors. + ([#2879](https://github.com/commercialhaskell/stack/issues/2879)) +* `stack ghci` now takes `--flag` and `--ghc-options` again (inadverently + removed in 1.3.0). + ([#2986](https://github.com/commercialhaskell/stack/issues/2986)) +* `stack exec` now takes `--rts-options` which passes the given arguments inside of + `+RTS ... args .. -RTS` to the executable. This works around stack itself consuming + the RTS flags on Windows. ([#2986](https://github.com/commercialhaskell/stack/issues/2640)) +* Upgraded `http-client-tls` version, which now offers support for the + `socks5://` and `socks5h://` values in the `http_proxy` and `https_proxy` + environment variables. + +Bug fixes: + +* Bump to hpack 0.16.0 to avoid character encoding issues when reading and + writing on non-UTF8 systems. +* `stack ghci` will no longer ignore hsSourceDirs that contain `..`. ([#2895](https://github.com/commercialhaskell/stack/issues/2895)) +* `stack list-dependencies --license` now works for wired-in-packages, + like base. ([#2871](https://github.com/commercialhaskell/stack/issues/2871)) +* `stack setup` now correctly indicates when it uses system ghc + ([#2963](https://github.com/commercialhaskell/stack/issues/2963)) +* Fix to `stack config set`, in 1.3.2 it always applied to + the global project. + ([#2709](https://github.com/commercialhaskell/stack/issues/2709)) +* Previously, cabal files without exe or lib would fail on the "copy" step. + ([#2862](https://github.com/commercialhaskell/stack/issues/2862)) +* `stack upgrade --git` now works properly. Workaround for affected + versions (>= 1.3.0) is to instead run `stack upgrade --git --source-only`. + ([#2977](https://github.com/commercialhaskell/stack/issues/2977)) +* Added support for GHC 8's slightly different warning format for + dumping warnings from logs. +* Work around a bug in Cabal/GHC in which package IDs are not unique + for different source code, leading to Stack not always rebuilding + packages depending on local packages which have + changed. ([#2904](https://github.com/commercialhaskell/stack/issues/2904)) + ## 1.3.2 Bug fixes: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2016, Stack contributors +Copyright (c) 2015-2017, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -1,5 +1,119 @@ # Changelog +## 1.4.0 + +Release notes: + +* Docker images: + [fpco/stack-full](https://hub.docker.com/r/fpco/stack-full/) and + [fpco/stack-run](https://hub.docker.com/r/fpco/stack-run/) + are no longer being built for LTS 8.0 and above. + [fpco/stack-build](https://hub.docker.com/r/fpco/stack-build/) + images continue to be built with a + [simplified process](https://github.com/commercialhaskell/stack/tree/master/etc/dockerfiles/stack-build). + [#624](https://github.com/commercialhaskell/stack/issues/624) + +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 + the 01-index.tar.gz file, from the hackage-security project. This is + intended to address some download speed issues from Github for + people in certain geographic regions. There is now full support for + checking out specific cabal file revisions from downloaded tarballs + as well. If you manually specify a package index with only a Git + URL, Git will still be used. See + [#2780](https://github.com/commercialhaskell/stack/issues/2780) +* When you provide the `--resolver` argument to the `stack unpack` + command, any packages passed in by name only will be looked up in + the given snapshot instead of taking the latest version. For + example, `stack --resolver lts-7.14 unpack mtl` will get version + 2.2.1 of `mtl`, regardless of the latest version available in the + package indices. This will also force the same cabal file revision + to be used as is specified in the snapshot. + + Unpacking via a package identifier (e.g. `stack --resolver lts-7.14 + unpack mtl-2.2.1`) will ignore any settings in the snapshot and take + the most recent revision. + + For backwards compatibility with tools relying on the presence of a + `00-index.tar`, Stack will copy the `01-index.tar` file to + `00-index.tar`. Note, however, that these files are different; most + importantly, 00-index contains only the newest revisions of cabal + files, while 01-index contains all versions. You may still need to + update your tooling. +* Passing `--(no-)nix-*` options now no longer implies `--nix`, except for + `--nix-pure`, so that the user preference whether or not to use Nix is + honored even in the presence of options that change the Nix behavior. + +Other enhancements: + +* Internal cleanup: configuration types are now based much more on lenses +* `stack build` and related commands now allow the user to disable debug symbol stripping + with new `--no-strip`, `--no-library-stripping`, and `--no-executable-shipping` flags, + closing [#877](https://github.com/commercialhaskell/stack/issues/877). + Also turned error message for missing targets more readable ([#2384](https://github.com/commercialhaskell/stack/issues/2384)) +* `stack haddock` now shows index.html paths when documentation is already up to + date. Resolved [#781](https://github.com/commercialhaskell/stack/issues/781) +* Respects the `custom-setup` field introduced in Cabal 1.24. This + supercedes any `explicit-setup-deps` settings in your `stack.yaml` + and trusts the package's `.cabal` file to explicitly state all its + dependencies. +* If system package installation fails, `get-stack.sh` will fail as well. Also + shows warning suggesting to run `apt-get update` or similar, depending on the + OS. + ([#2898](https://github.com/commercialhaskell/stack/issues/2898)) +* When `stack ghci` is run with a config with no packages (e.g. global project), + it will now look for source files in the current work dir. + ([#2878](https://github.com/commercialhaskell/stack/issues/2878)) +* Bump to hpack 0.17.0 to allow `custom-setup` and `!include "..."` in `package.yaml`. +* The script interpreter will now output error logging. In particular, + this means it will output info about plan construction errors. + ([#2879](https://github.com/commercialhaskell/stack/issues/2879)) +* `stack ghci` now takes `--flag` and `--ghc-options` again (inadverently + removed in 1.3.0). + ([#2986](https://github.com/commercialhaskell/stack/issues/2986)) +* `stack exec` now takes `--rts-options` which passes the given arguments inside of + `+RTS ... args .. -RTS` to the executable. This works around stack itself consuming + the RTS flags on Windows. ([#2986](https://github.com/commercialhaskell/stack/issues/2640)) +* Upgraded `http-client-tls` version, which now offers support for the + `socks5://` and `socks5h://` values in the `http_proxy` and `https_proxy` + environment variables. + +Bug fixes: + +* Bump to hpack 0.16.0 to avoid character encoding issues when reading and + writing on non-UTF8 systems. +* `stack ghci` will no longer ignore hsSourceDirs that contain `..`. ([#2895](https://github.com/commercialhaskell/stack/issues/2895)) +* `stack list-dependencies --license` now works for wired-in-packages, + like base. ([#2871](https://github.com/commercialhaskell/stack/issues/2871)) +* `stack setup` now correctly indicates when it uses system ghc + ([#2963](https://github.com/commercialhaskell/stack/issues/2963)) +* Fix to `stack config set`, in 1.3.2 it always applied to + the global project. + ([#2709](https://github.com/commercialhaskell/stack/issues/2709)) +* Previously, cabal files without exe or lib would fail on the "copy" step. + ([#2862](https://github.com/commercialhaskell/stack/issues/2862)) +* `stack upgrade --git` now works properly. Workaround for affected + versions (>= 1.3.0) is to instead run `stack upgrade --git --source-only`. + ([#2977](https://github.com/commercialhaskell/stack/issues/2977)) +* Added support for GHC 8's slightly different warning format for + dumping warnings from logs. +* Work around a bug in Cabal/GHC in which package IDs are not unique + for different source code, leading to Stack not always rebuilding + packages depending on local packages which have + changed. ([#2904](https://github.com/commercialhaskell/stack/issues/2904)) + ## 1.3.2 Bug fixes: diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -16,8 +16,8 @@ ### What makes stack special? -The primary stack design point is __reproducible builds__. If you run `stack -build` today, you should get the same result running `stack build` tomorrow. +The primary stack design point is __reproducible builds__. If you run `stack build` +today, you should get the same result running `stack build` tomorrow. There are some cases that can break that rule (changes in your operating system configuration, for example), but, overall, stack follows this design philosophy closely. To make this a simple process, stack uses curated package sets @@ -195,7 +195,7 @@ Looking closely at the output of the previous command, you can see that it built both a library called "helloworld" and an executable called "helloworld-exe". We'll explain more in the next section, but, for now, just notice that the -executables are installed in our project's `./stack-work` directory. +executables are installed in our project's `./.stack-work` directory. Now, Let's use `stack exec` to run our executable (which just outputs the string "someFunc"): @@ -207,7 +207,7 @@ `stack exec` works by providing the same reproducible environment that was used to build your project to the command that you are running. Thus, it knew where -to find `helloworld-exe` even though it is hidden in the `./stack-work` +to find `helloworld-exe` even though it is hidden in the `./.stack-work` directory. ### stack test @@ -264,11 +264,11 @@ The `app/Main.hs`, `src/Lib.hs`, and `test/Spec.hs` files are all Haskell source files that compose the actual functionality of our project (we won't dwell on -them here). The LICENSE file has no impact on the build, but is there for -informational/legal purposes only. The files of interest here are Setup.hs, -helloworld.cabal, and stack.yaml. +them here). The `LICENSE` file has no impact on the build, but is there for +informational/legal purposes only. The files of interest here are `Setup.hs`, +`helloworld.cabal`, and `stack.yaml`. -The Setup.hs file is a component of the Cabal build system which stack uses. +The `Setup.hs` file is a component of the Cabal build system which stack uses. It's technically not needed by stack, but it is still considered good practice in the Haskell world to include it. The file we're using is straight boilerplate: @@ -278,7 +278,7 @@ main = defaultMain ``` -Next, let's look at our stack.yaml file, which gives our project-level settings: +Next, let's look at our `stack.yaml` file, which gives our project-level settings: ```yaml flags: {} @@ -296,22 +296,22 @@ has powerful support for multi-package projects, which we'll elaborate on as this guide progresses. -The final field is resolver. This tells stack *how* to build your package: +The final field is `resolver`. This tells stack *how* to build your package: which GHC version to use, versions of package dependencies, and so on. Our value here says to use [LTS Haskell version 3.2](https://www.stackage.org/lts-3.2), which implies GHC 7.10.2 (which is why `stack setup` installs that version of GHC). There are a number of values you -can use for resolver, which we'll cover later. +can use for `resolver`, which we'll cover later. -The final file of import is helloworld.cabal. stack is built on top of the +The final file of import is `helloworld.cabal`. stack is built on top of the Cabal build system. In Cabal, we have individual *packages*, each of which -contains a single .cabal file. The .cabal file can define 1 or more +contains a single `.cabal` file. The `.cabal` file can define 1 or more *components*: a library, executables, test suites, and benchmarks. It also specifies additional information such as library dependencies, default language pragmas, and so on. In this guide, we'll discuss the bare minimum necessary to understand how to -modify a .cabal file. Haskell.org has the definitive [reference for the .cabal +modify a `.cabal` file. Haskell.org has the definitive [reference for the `.cabal` file format](https://www.haskell.org/cabal/users-guide/developing-packages.html). ### The setup command @@ -328,8 +328,8 @@ ``` Thankfully, the command is smart enough to know not to perform an installation -twice. As the command output above indicates, you can use `stack -path` for quite a bit of path information (which we'll play with more later). +twice. As the command output above indicates, you can use `stack path` +for quite a bit of path information (which we'll play with more later). For now, we'll just look at where GHC is installed: ``` @@ -392,7 +392,7 @@ Notice that it says "Could not find module." This means that the package containing the module in question is not available. To tell stack to use text, -you need to add it to your .cabal file — specifically in your build-depends +you need to add it to your `.cabal` file — specifically in your build-depends section, like this: ``` @@ -496,7 +496,7 @@ someFunc = launchMissiles ``` -Again, we add this new dependency to the .cabal file like this: +Again, we add this new dependency to the `.cabal` file like this: ``` library @@ -538,9 +538,9 @@ text package, it just worked, because it was part of the lts-3.2 *package set*. But acme-missiles is not part of that package set, so building failed. -To add this new dependency, we'll use the `extra-deps` field in stack.yaml to +To add this new dependency, we'll use the `extra-deps` field in `stack.yaml` to define extra dependencies not present in the resolver. With that change, our -stack.yaml looks like: +`stack.yaml` looks like: ```yaml flags: {} @@ -564,7 +564,7 @@ * The ability to perform a Hoogle search on the packages in this snapshot * A [list of all modules](https://www.stackage.org/lts-3.2/docs) in a snapshot, which can be useful when trying to determine which package to add to your - .cabal file + `.cabal` file You can also see a [list of all available snapshots](https://www.stackage.org/snapshots). You'll notice two flavors: LTS @@ -576,7 +576,7 @@ ## Resolvers and changing your compiler version Let's explore package sets a bit further. Instead of lts-3.2, let's change our -stack.yaml file to use +`stack.yaml` file to use [nightly-2015-08-26](https://www.stackage.org/nightly-2015-08-26). Rerunning `stack build` will produce: @@ -621,7 +621,7 @@ versions of resolvers: `--resolver nightly` will use the newest Nightly resolver available, `--resolver lts` will use the newest LTS, and `--resolver lts-2` will use the newest LTS in the 2.X series. The reason these are only available on the -command line and not in your stack.yaml file is that using them: +command line and not in your `stack.yaml` file is that using them: 1. Will slow down your build (since stack then needs to download information on the latest available LTS each time it builds) @@ -685,8 +685,8 @@ Alright, enough playing around with simple projects. Let's take an open source package and try to build it. We'll be ambitious and use [yackage](https://www.stackage.org/package/yackage), a local package server -using [Yesod](http://www.yesodweb.com/). To get the code, we'll use the `stack -unpack` command: +using [Yesod](http://www.yesodweb.com/). To get the code, we'll use the +`stack unpack` command: ``` cueball:~$ stack unpack yackage-0.8.0 @@ -695,7 +695,7 @@ ``` ### stack init -This new directory does not have a stack.yaml file, so we need to make one +This new directory does not have a `stack.yaml` file, so we need to make one first. We could do it by hand, but let's be lazy instead with the `stack init` command: @@ -717,7 +717,7 @@ stack init does quite a few things for you behind the scenes: -* Finds all of the .cabal files in your current directory and subdirectories +* Finds all of the `.cabal` files in your current directory and subdirectories (unless you use `--ignore-subdirs`) and determines the packages and versions they require * Finds the best combination of snapshot and package flags that allows everything to @@ -725,7 +725,7 @@ * It tries to look for the best matching snapshot from latest LTS, latest nightly, other LTS versions in that order -Assuming it finds a match, it will write your stack.yaml file, and everything +Assuming it finds a match, it will write your `stack.yaml` file, and everything will work. #### External Dependencies @@ -813,7 +813,7 @@ All done. ``` -As you can verify by viewing stack.yaml, three external dependencies were added +As you can verify by viewing `stack.yaml`, three external dependencies were added by stack init: ``` @@ -825,20 +825,20 @@ ``` Of course, you could have added the external dependencies by manually editing -stack.yaml but stack init does the hard work for you. +`stack.yaml` but stack init does the hard work for you. #### Excluded Packages Sometimes multiple packages in your project may have conflicting requirements. In that case `stack init` will fail, so what do you do? -You could manually create stack.yaml by omitting some packages to resolve the +You could manually create `stack.yaml` by omitting some packages to resolve the conflict. Alternatively you can ask `stack init` to do that for you by specifying `--omit-packages` flag on the command line. Let's see how that works. To simulate a conflict we will use acme-missiles-0.3 in yackage and we will -also copy yackage.cabal to another directory and change the name of the file +also copy `yackage.cabal` to another directory and change the name of the file and package to yackage-test. In this new package we will use acme-missiles-0.2 instead. Let's see what happens when we run solver: @@ -908,8 +908,8 @@ #### Using a specific resolver Sometimes you may want to use a specific resolver for your project instead of -`stack init` picking one for you. You can do that by using `stack init ---resolver `. +`stack init` picking one for you. You can do that by using +`stack init --resolver `. You can also init with a compiler resolver if you do not want to use a snapshot. That will result in all of your project's dependencies being put @@ -930,7 +930,7 @@ same name, stack init will report those and automatically ignore one of them. _Ignore subdirectories_: By default stack init searches all the subdirectories -for .cabal files. If you do not want that then you can use `--ignore-subdirs` +for `.cabal` files. If you do not want that then you can use `--ignore-subdirs` command line switch. _Cabal warnings_: stack init will show warnings if there were issues in reading @@ -1039,7 +1039,7 @@ By default it does not make changes to the config. As it suggested you can use `--update-config` to make changes to the config. -NOTE: You should probably back up your stack.yaml before doing this, such as +NOTE: You should probably back up your `stack.yaml` before doing this, such as committing to Git/Mercurial/Darcs. Sometimes, you may want to use specific versions of certain packages for your @@ -1047,8 +1047,8 @@ extra-deps section and then use `stack solver` to figure out whether it is feasible to use those or what other dependencies are needed as a result. -If you want to change the resolver for your project, you can run `stack solver ---resolver ` and it will figure out the changes needed for you. +If you want to change the resolver for your project, you can run +`stack solver --resolver ` and it will figure out the changes needed for you. Let's see what happens if we change the resolver to lts-2.22: @@ -1252,8 +1252,8 @@ That's why the download page recommends adding that directory to your `PATH` environment variable. This feature is convenient, because now you can simply -run `executable-name` in your shell instead of having to run `stack exec -executable-name` from inside your project directory. +run `executable-name` in your shell instead of having to run +`stack exec executable-name` from inside your project directory. Since it's such a point of confusion, let me list a number of things stack does *not* do specially for the install command: @@ -1402,7 +1402,7 @@ # Goes off to build a whole bunch of packages ``` -If you look at the stack.yaml, you'll see exactly what you'd expect: +If you look at the `stack.yaml`, you'll see exactly what you'd expect: ```yaml flags: @@ -1435,7 +1435,7 @@ ### Cabal flag management -In the stack.yaml file above, you can see that `stack init` has detected that — +In the `stack.yaml` file above, you can see that `stack init` has detected that — for the yackage package — the upload flag can be set to true, and for wai-app-static, the print flag to false (it's chosen those values because they're the default flag values, and their dependencies are compatible with the @@ -1512,7 +1512,7 @@ confusion. Final point: if you have GHC options that you'll be regularly passing to your -packages, you can add them to your stack.yaml file (starting with +packages, you can add them to your `stack.yaml` file (starting with stack-0.1.4.0). See [the documentation section on ghc-options](yaml_configuration.md#ghc-options) for more information. @@ -1618,7 +1618,7 @@ IMPORTANT NOTE: If you have added upstream packages to your project please make sure to mark them as *dependency package*s for faster and reliable usage of -`stack gchi`. Otherwise GHCi may have trouble due to conflicts of compilation +`stack ghci`. Otherwise GHCi may have trouble due to conflicts of compilation flags or having to unnecessarily interpret too many modules. See [stack.yaml documentation](yaml_configuration.md#packages) to learn how to mark a package as a *dependency package*. @@ -1626,8 +1626,8 @@ ## ghc/runghc You'll sometimes want to just compile (or run) a single Haskell source file, -instead of creating an entire Cabal package for it. You can use `stack exec -ghc` or `stack exec runghc` for that. As simple helpers, we also provide the +instead of creating an entire Cabal package for it. You can use `stack exec ghc` +or `stack exec runghc` for that. As simple helpers, we also provide the `stack ghc` and `stack runghc` commands, for these common cases. ## script interpreter @@ -1646,23 +1646,17 @@ 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 @@ 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,53 +1716,64 @@ 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. +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`: -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 +#!/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 +Whenever you run something with stack, it needs a `stack.yaml` project file. The algorithm stack uses to find this is: 1. Check for a `--stack-yaml` option on the command line @@ -1759,11 +1783,11 @@ The first two provide a convenient method for using an alternate configuration. For example: `stack build --stack-yaml stack-7.8.yaml` can be used by your CI system to check your code against GHC 7.8. Setting the `STACK_YAML` environment -variable can be convenient if you're going to be running commands like `stack -ghc` in other directories, but you want to use the configuration you defined in +variable can be convenient if you're going to be running commands like `stack ghc` +in other directories, but you want to use the configuration you defined in a specific project. -If stack does not find a stack.yaml in any of the three specified locations, +If stack does not find a `stack.yaml` in any of the three specified locations, the *implicit global* logic kicks in. You've probably noticed that phrase a few times in the output from commands above. Implicit global is essentially a hack to allow stack to be useful in a non-project setting. When no implicit global @@ -1778,20 +1802,20 @@ with it is put into isolated databases just like everywhere else. The only magic is that it's the catch-all project whenever you're running stack somewhere else. -## stack.yaml vs .cabal files +## `stack.yaml` vs `.cabal` files Now that we've covered a lot of stack use cases, this quick summary of -stack.yaml vs .cabal files will hopefully make sense and be a good reminder for +`stack.yaml` vs `.cabal` files will hopefully make sense and be a good reminder for future uses of stack: * A project can have multiple packages. -* Each project has a stack.yaml. -* Each package has a .cabal file. -* The .cabal file specifies which packages are dependencies. -* The stack.yaml file specifies which packages are available to be used. -* .cabal specifies the components, modules, and build flags provided by a package -* stack.yaml can override the flag settings for individual packages -* stack.yaml specifies which packages to include +* Each project has a `stack.yaml`. +* Each package has a `.cabal` file. +* The `.cabal` file specifies which packages are dependencies. +* The `stack.yaml` file specifies which packages are available to be used. +* `.cabal` specifies the components, modules, and build flags provided by a package +* `stack.yaml` can override the flag settings for individual packages +* `stack.yaml` specifies which packages to include ## Comparison to other tools @@ -1810,7 +1834,7 @@ Before jumping into the differences, let me clarify an important similarity: __Same package format.__ stack, cabal-install, and presumably all other tools -share the same underlying Cabal package format, consisting of a .cabal file, +share the same underlying Cabal package format, consisting of a `.cabal` file, modules, etc. This is a Good Thing: we can share the same set of upstream libraries, and collaboratively work on the same project with stack, cabal-install, and NixOS. In that sense, we're sharing the same ecosystem. @@ -1839,8 +1863,8 @@ packages. So for example, in stack, `stack test` does the same job as `cabal install --run-tests`, though the latter *additionally* performs an installation that you may not want. The closer command equivalent is - `cabal install --enable-tests --only-dependencies && cabal configure - --enable-tests && cabal build && cabal test` (newer versions of + `cabal install --enable-tests --only-dependencies && cabal configure --enable-tests && cabal build && cabal test` + (newer versions of cabal-install may make this command shorter). * __Isolated by default__. * This has been a pain point for new stack users. In cabal, the @@ -2038,12 +2062,12 @@ most users won't use it regularly. It does what you'd expect: downloads a tarball and unpacks it. * `stack sdist` generates an uploading tarball containing your package code -* `stack upload` uploads an sdist to Hackage. In the future, it will also - perform automatic GPG signing of your packages for additional security, when - configured. - * `--sign` provides a way to GPG sign your package & submit the result to - sig.commercialhaskell.org for storage in the sig-archive git - repo. (Signatures will be used later to verify package integrity.) +* `stack upload` uploads an sdist to Hackage. As of + version [1.1.0](https://docs.haskellstack.org/en/latest/ChangeLog/#110) stack + will also attempt to GPG sign your packages as + per + [our blog post](https://www.fpcomplete.com/blog/2016/05/stack-security-gnupg-keys). + * `--no-signature` disables signing of packages * `stack upgrade` will build a new version of stack from source. * `--git` is a convenient way to get the most recent version from master for those testing and living on the bleeding edge. @@ -2101,10 +2125,11 @@ ### DWARF -`stack` currently doesn't support debugging and profiling with -[DWARF information](https://ghc.haskell.org/trac/ghc/wiki/DWARF) -as it strips executables automatically. This may change in the future (see -[#877](https://github.com/commercialhaskell/stack/issues/877)). +`stack` now supports debugging and profiling with +[DWARF information](https://ghc.haskell.org/trac/ghc/wiki/DWARF), +using the `--no-strip`, `--no-library-stripping`, and `--no-executable-shipping` +flags to disable the default behavior of removing such information from compiled +libraries and executables. ### Further reading diff --git a/doc/MAINTAINER_GUIDE.md b/doc/MAINTAINER_GUIDE.md --- a/doc/MAINTAINER_GUIDE.md +++ b/doc/MAINTAINER_GUIDE.md @@ -2,18 +2,17 @@ ## Next release: -* Stop building Linux distro - packages [#2534](https://github.com/commercialhaskell/stack/issues/2534) - ## Pre-release steps * Ensure `release` and `stable` branches merged to `master` -* Check compatibility with latest stackage snapshot +* Check compatibility with latest nightly stackage snapshot: + * Update `stack-nightly.yaml` with latest nightly and remove extra-deps + * Run `stack --stack-yaml=stack-nightly.yaml test` * Ensure integration tests pass on a representative Windows, macOS, and Linux (Linux - is handled by Jenkins automatically): `stack install --pedantic && stack test - --pedantic --flag stack:integration-tests` . The actual release script will - perform a more thorough test for every platform/variant prior to uploading, so - this is just a pre-check + is handled by Jenkins automatically): + `stack install --pedantic && stack test --pedantic --flag stack:integration-tests`. + The actual release script will perform a more thorough test for every platform/variant + prior to uploading, so this is just a pre-check * Ensure `stack haddock` works (Travis CI now does this) * Stack builds with `stack-7.8.yaml` (Travis CI now does this) * stack can build the wai repo @@ -43,10 +42,10 @@ * Look for any links to "latest" documentation, replace with version tag * Ensure all documentation pages listed in `mkdocs.yaml` * Update the ISSUE_TEMPLATE.md to point at the new version. - * Check that any new Linux distribution versions added to + * (SKIP) Check that any new Linux distribution versions added to `etc/scripts/release.hs` and `etc/scripts/vagrant-releases.sh` * [Ubuntu](https://wiki.ubuntu.com/Releases) - * [Debian](https://www.debian.org/releases/) (keep at least latest two) + * [Debian](https://www.debian.org/releases/) * [CentOS](https://wiki.centos.org/Download) * [Fedora](https://fedoraproject.org/wiki/Releases) * Check for new [FreeBSD release](https://www.freebsd.org/releases/). @@ -55,9 +54,16 @@ [install_and_upgrade.md](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md), and `README.md` - * Remove unsupported/obsolete distribution versions from - [install_and_upgrade.md](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md), - and perhaps from the release process. + * Remove unsupported/obsolete distribution versions from the release process. + * [Ubuntu](https://wiki.ubuntu.com/Releases) + * 12.04 EOL 2017-APR + * 16.10 EOL 2017-JUL + * 14.04 EOL 2019-APR + * 16.04 EOL 2021-APR + * [Debian](https://www.debian.org/releases/) + * [CentOS](https://wiki.centos.org/Download) + * 6 EOL 2020-NOV-30 + * 7 EOL 2024-JUN-30 ## Release process @@ -67,8 +73,8 @@ A note about the `etc/scripts/*-releases.sh` scripts: if you run them from a different working tree than the scripts themselves (e.g. if you have `stack1` -and `stack2` trees, and run `cd stack1; -../stack2/etc/scripts/vagrant-release.sh`) the scripts and Vagrantfiles from the +and `stack2` trees, and run `cd stack1; ../stack2/etc/scripts/vagrant-release.sh`) +the scripts and Vagrantfiles from the tree containing the script will be used to build the stack code in the current directory. That allows you to iterate on the release process while building a consistent and clean stack version. @@ -104,8 +110,8 @@ * Build sdist using `stack sdist . --pvp-bounds=both`, and upload it to the Github release with a name like `stack-X.Y.Z-sdist-0.tar.gz`. -* Publish Github release. Use e.g. `git shortlog -s v1.1.2..rc/v1.2.0|sed - 's/^[0-9 ]*/* /'|sort -f` to get the list of contributors. +* Publish Github release. Use e.g. `git shortlog -s v1.1.2..rc/v1.2.0|sed 's/^[0-9 ]*/* /'|sort -f` + to get the list of contributors. * Upload package to Hackage: `stack upload . --pvp-bounds=both` @@ -120,11 +126,9 @@ * (SKIP) [Flag the Arch Linux package as out-of-date](https://www.archlinux.org/packages/community/x86_64/stack/flag/) -* Push signed Git tag, matching Github release tag name, e.g.: `git tag -d vX.Y.Z; git tag -u - 0x575159689BEFB442 vX.Y.Z && git push -f origin vX.Y.Z` +* Push signed Git tag, matching Github release tag name, e.g.: `git tag -d vX.Y.Z; git tag -u 0x575159689BEFB442 vX.Y.Z && git push -f origin vX.Y.Z` -* Reset the `release` branch to the released commit, e.g.: `git checkout release - && git merge --ff-only vX.Y.Z && git push origin release` +* Reset the `release` branch to the released commit, e.g.: `git checkout release && git merge --ff-only vX.Y.Z && git push origin release` * Update the `stable` branch similarly @@ -368,6 +372,9 @@ In the case of macOS, repackage the `.xz` bindist as a `.bz2`, since macOS does not include `xz` by default or provide an easy way to install it. + The script at `etc/scripts/mirror-ghc-bindists-to-github.sh` will help with + this. See the comments within the script. + * Build any additional required bindists (see below for instructions) * tinfo6 (`etc/vagrant/fedora24-x86_64`) @@ -384,9 +391,10 @@ For GHC >= 7.10.2, set the `GHC_VERSION` environment variable to the version to build: - * `export GHC_VERSION=8.0.1` - * `export GHC_VERSION=7.10.3a` - * `export GHC_VERSION=7.10.2` + * `export GHC_VERSION=8.0.2` + * `export GHC_VERSION=8.0.1` + * `export GHC_VERSION=7.10.3a` + * `export GHC_VERSION=7.10.2` then, run (from [here](https://ghc.haskell.org/trac/ghc/wiki/Newcomers)): diff --git a/doc/README.md b/doc/README.md --- a/doc/README.md +++ b/doc/README.md @@ -27,7 +27,7 @@ operating system/distribution: * [Windows](install_and_upgrade.md#windows) -* [macOS](install_and_upgrade.md#mac-os-x) +* [macOS](install_and_upgrade.md#macos) * [Ubuntu](install_and_upgrade.md#ubuntu) * [Debian](install_and_upgrade.md#debian) * [CentOS / Red Hat / Amazon Linux](install_and_upgrade.md#centos) diff --git a/doc/build_command.md b/doc/build_command.md --- a/doc/build_command.md +++ b/doc/build_command.md @@ -22,8 +22,8 @@ * `stack install` is the same as `stack build --copy-bins` The advantage of the synonym commands is that they're convenient and short. The -advantage of the options is that they compose. For example, `stack build --test ---copy-bins` will build libraries, executables, and test suites, run the test +advantage of the options is that they compose. For example, `stack build --test --copy-bins` +will build libraries, executables, and test suites, run the test suites, and then copy the executables to your local bin path (more on this below). @@ -56,8 +56,8 @@ ## Target syntax -In addition to a number of options (like the aforementioned `--test`), `stack -build` takes a list of zero or more *targets* to be built. There are a number +In addition to a number of options (like the aforementioned `--test`), `stack build` +takes a list of zero or more *targets* to be built. There are a number of different syntaxes supported for this list: * *package*, e.g. `stack build foobar`, is the most commonly used target. It @@ -94,8 +94,7 @@ have a component with the same name. To continue the above example, `stack build :mytestsuite`. * Side note: the commonly requested `run` command is not available - because it's a simple combination of `stack build :exename && stack - exec exename` + because it's a simple combination of `stack build :exename && stack exec exename` * *directory*, e.g. `stack build foo/bar`, will find all local packages that exist in the given directory hierarchy and then follow the same procedure as @@ -106,8 +105,7 @@ Finally: if you provide no targets (e.g., running `stack build`), stack will implicitly pass in all of your local packages. If you only want to target -packages in the current directory or deeper, you can pass in `.`, e.g. `stack -build .`. +packages in the current directory or deeper, you can pass in `.`, e.g. `stack build .`. To get a list of the available targets in your project, use `stack ide targets`. diff --git a/doc/coverage.md b/doc/coverage.md --- a/doc/coverage.md +++ b/doc/coverage.md @@ -22,8 +22,8 @@ 2) A unified textual and HTML report, considering the coverage on all local libraries, based on all of the tests that were run. -3) An index of all generated HTML reports, at `$(stack path - --local-hpc-root)/index.html`. +3) An index of all generated HTML reports, at + `$(stack path --local-hpc-root)/index.html`. ## "stack hpc report" command @@ -81,8 +81,8 @@ When switching on this flag, it will usually cause all local packages to be rebuilt (see [#1940](https://github.com/commercialhaskell/stack/issues/1940). -2. Before the build runs with `--coverage`, the contents of `stack path - --local-hpc-root` gets deleted. This prevents old reports from getting mixed +2. Before the build runs with `--coverage`, the contents of `stack path --local-hpc-root` + gets deleted. This prevents old reports from getting mixed with new reports. If you want to preserve report information from multiple runs, copy the contents of this path to a new folder. @@ -90,8 +90,8 @@ it will be deleted. 4. After a test run, it will expect a `test-name.tix` file to exist. This file - will then get loaded, modified, and outputted to `$(stack path - --local-hpc-root)/pkg-name/test-name/test-name.tix)`. + will then get loaded, modified, and outputted to + `$(stack path --local-hpc-root)/pkg-name/test-name/test-name.tix)`. The `.tix` file gets modified to remove coverage file that isn't associated with a library. So, this means that you won't get coverage information for @@ -107,8 +107,8 @@ 5. Once we have a `.tix` file for a test, we also generate a textual and HTML report for it. The textual report is sent to the terminal. The index of the - test-specific HTML report is available at `$(stack path - --local-hpc-root)/pkg-name/test-name/index.html` + test-specific HTML report is available at + `$(stack path --local-hpc-root)/pkg-name/test-name/index.html` 6. After the build completes, if there are multiple output `*.tix` files, they get combined into a unified report. The index of this report will be @@ -116,5 +116,4 @@ 7. Finally, an index of the resulting coverage reports is generated. It links to the individual coverage reports (one for each test-suite), as well as the - unified report. This index is available at `$(stack path - --local-hpc-root)/index.html` + unified report. This index is available at `$(stack path --local-hpc-root)/index.html` diff --git a/doc/docker_integration.md b/doc/docker_integration.md --- a/doc/docker_integration.md +++ b/doc/docker_integration.md @@ -137,8 +137,8 @@ ### reset - Reset the Docker "sandbox" In order to preserve the contents of the in-container home directory between -runs, a special "sandbox" directory is volume-mounted into the container. `stack -docker reset` will reset that sandbox to its defaults. +runs, a special "sandbox" directory is volume-mounted into the container. +`stack docker reset` will reset that sandbox to its defaults. Note: `~/.stack` is separately volume-mounted, and is left alone during reset. @@ -268,19 +268,6 @@ - [fpco/stack-build](https://registry.hub.docker.com/u/fpco/stack-build/) (the default) - GHC (patched), tools (stack, cabal-install, happy, alex, etc.), and system developer libraries required to build all Stackage packages. -- [fpco/stack-ghcjs-build](https://registry.hub.docker.com/u/fpco/stack-ghcjs-build/) - - Like `stack-build`, but adds GHCJS. -- [fpco/stack-full](https://registry.hub.docker.com/u/fpco/stack-full/) - - Includes all Stackage packages pre-installed in GHC's global package database. - These images are over 10 GB! -- [fpco/stack-ghcjs-full](https://registry.hub.docker.com/u/fpco/stack-ghcjs-full/) - - Like `stack-full`, but adds GHCJS. -- [fpco/stack-run](https://registry.hub.docker.com/u/fpco/stack-run/) - - Runtime environment for binaries built with Stackage. Includes system shared - libraries required by all Stackage packages. Does not necessarily include all - data required for every use (e.g. has texlive-binaries for HaTeX, but does not - include LaTeX fonts), as that would be prohibitively large. Based on - [phusion/baseimage](https://registry.hub.docker.com/u/phusion/baseimage/). FP Complete also builds custom variants of these images for their clients. @@ -323,8 +310,8 @@ ### Volume-mounts and ephemeral containers Since filesystem changes outside of the volume-mounted project directory are not -persisted across runs, this means that if you `stack exec sudo apt-get install -some-ubuntu-package`, that package will be installed but then the container it's +persisted across runs, this means that if you `stack exec sudo apt-get install some-ubuntu-package`, +that package will be installed but then the container it's installed in will disappear, thus causing it to have no effect. If you wish to make this kind of change permanent, see later instructions for how to create a [derivative Docker image](#derivative-image). @@ -353,8 +340,8 @@ If you do want to do all your work, including editing, in the container, it might be better to use a persistent container in which you can install Ubuntu -packages. You could get that by running something like `stack ---docker-container-name=NAME --docker-persist exec --plain bash`. This +packages. You could get that by running something like +`stack --docker-container-name=NAME --docker-persist exec --plain bash`. This means when the container exits, it won't be deleted. You can then restart it using `docker start -a -i NAME`. It's also possible to detach from a container while it continues running in the background using by pressing Ctrl-P Ctrl-Q, @@ -419,17 +406,16 @@ ### "No Space Left on Device", but 'df' shows plenty of disk space This is likely due to the storage driver Docker is using, in combination with -the large size and number of files in these images. Use `docker info|grep -'Storage Driver'` to determine the current storage driver. +the large size and number of files in these images. Use `docker info|grep 'Storage Driver'` +to determine the current storage driver. We recommend using either the `overlay` or `aufs` storage driver for stack, as they are least likely to give you trouble. On Ubuntu, `aufs` is the default for new installations, but older installations sometimes used `devicemapper`. -The `devicemapper` storage driver's default configuration limits it to a 10 GB -file system, which the "full" images exceed. We have experienced other -instabilities with it as well on Ubuntu, and recommend against its use for this -purpose. +The `devicemapper` storage driver's doesn't work well with large filesystems, +and we have experienced other instabilities with it as well. We recommend +against its use. The `btrfs` storage driver has problems running out of metadata space long before running out of actual disk space, which requires rebalancing or adding @@ -467,9 +453,8 @@ The above commands turn off `dnsmasq` usage in NetworkManager configuration and restart network manager. They can be reversed by executing -`sudo sed 's@#dns=dnsmasq@dns=dnsmasq@' -i -/etc/NetworkManager/NetworkManager.conf && sudo service network-manager -restart`. These instructions are adapted from +`sudo sed 's@#dns=dnsmasq@dns=dnsmasq@' -i /etc/NetworkManager/NetworkManager.conf && sudo service network-manager restart`. +These instructions are adapted from [the Shipyard Project's QuickStart guide](https://github.com/shipyard/shipyard/wiki/QuickStart#127011-dns-server-problem-on-ubuntu). diff --git a/doc/faq.md b/doc/faq.md --- a/doc/faq.md +++ b/doc/faq.md @@ -191,9 +191,8 @@ ## How do I upgrade to GHC 7.10.2 with stack? -If you already have a prior version of GHC use `stack --resolver ghc-7.10 setup ---reinstall`. If you don't have any GHC installed, you can skip the -`--reinstall`. +If you already have a prior version of GHC use `stack --resolver ghc-7.10 setup --reinstall`. +If you don't have any GHC installed, you can skip the `--reinstall`. ## How do I get extra build tools? @@ -201,8 +200,8 @@ dependencies, in particular alex and happy. __NOTE__: This works when using lts or nightly resolvers, not with ghc or -custom resolvers. You can manually install build tools by running, e.g., `stack -build alex happy`. +custom resolvers. You can manually install build tools by running, e.g., +`stack build alex happy`. ## How does stack choose which snapshot to use when creating a new config file? @@ -402,7 +401,7 @@ The issue may be related to the use of hardening flags in some cases, specifically those related to producing position independent executables (PIE). This is tracked upstream in the [following -ticket](https://ghc.haskell.org/trac/ghc/ticket/9007). Some distributions add +ticket](https://ghc.haskell.org/trac/ghc/ticket/12759). Some distributions add such hardening flags by default which may be the cause of some instances of the problem. Therefore, a possible workaround might be to turn off PIE related flags. @@ -418,8 +417,8 @@ ## Where does the output from `--ghc-options=-ddump-splices` (and other `-ddump*` options) go? These are written to `*.dump-*` files inside the package's `.stack-work` -directory. Specifically, they will be available at `PKG-DIR/$(stack path ---dist-dir)/build/SOURCE-PATH`, where `SOURCE-PATH` is the path to the source +directory. Specifically, they will be available at +`PKG-DIR/$(stack path --dist-dir)/build/SOURCE-PATH`, where `SOURCE-PATH` is the path to the source file, relative to the location of the `*.cabal` file. When building named components such as test-suites, `SOURCE-PATH` will also include `COMPONENT/COMPONENT-tmp`, where `COMPONENT` is the name of the component. @@ -488,3 +487,10 @@ Use the `SYSTEM_CERTIFICATE_PATH` environment variable to point at the directory where you keep your SSL certificates. + +## How do I get `verbose` output from GHC when I build with cabal? + +Unfortunately `stack build` does not have an obvious equivalent to `cabal build -vN` which shows verbose output from GHC when building. The easiest workaround is to add `ghc-options: -vN` to the .cabal file or pass it via `stack build --ghc-options="-v"`. + +## Does Stack support the Hpack specification? +Yes. You can run `stack init` as usual and Stack will create a matching `stack.yaml`. diff --git a/doc/ghcjs.md b/doc/ghcjs.md --- a/doc/ghcjs.md +++ b/doc/ghcjs.md @@ -9,9 +9,9 @@ You can also build existing stack projects which target GHC, and instead build them with GHCJS. For example: `stack build --compiler ghcjs-0.2.0.9006020_ghc-7.10.3` -Sidenote: If you receive a message like `The program 'ghcjs' version >=0.1 is -required but the version of .../ghcjs could not be determined.`, then you may -need to install a different version of `node`. See +Sidenote: If you receive a message like +`The program 'ghcjs' version >=0.1 is required but the version of .../ghcjs could not be determined.`, +then you may need to install a different version of `node`. See [issue #1496](https://github.com/commercialhaskell/stack/issues/1496). ## Example Configurations @@ -25,52 +25,55 @@ For `ghcjs` based on `ghc-7.10.3` one could try: ```yaml -resolver: lts-6.25 -compiler: ghcjs-0.2.0.9006025_ghc-7.10.3 +resolver: lts-6.30 +compiler: ghcjs-0.2.0.9006030_ghc-7.10.3 compiler-check: match-exact setup-info: ghcjs: source: - ghcjs-0.2.0.9006025_ghc-7.10.3: - url: http://ghcjs.tolysz.org/lts-6.25-9006025.tar.gz - sha1: 3c87228579b55c05e227a7876682c2a7d4c9c007 + ghcjs-0.2.0.9006030_ghc-7.10.3: + url: http://ghcjs.tolysz.org/lts-6.30-9006030.tar.gz + sha1: 2371e2ffe9e8781808b7a04313e6a0065b64ee51 ``` Or for the latest one based on `ghc-8.0.1` (with more features): ```yaml -resolver: lts-7.14 -compiler: ghcjs-0.2.1.9007014_ghc-8.0.1 +resolver: lts-7.19 +compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 compiler-check: match-exact setup-info: ghcjs: source: - ghcjs-0.2.1.9007014_ghc-8.0.1: - url: http://ghcjs.tolysz.org/ghc-8.0-2016-12-25-lts-7.14-9007014.tar.gz - sha1: 0d2ebe0931b29adca7cb9d9b9f77d60095bfb864 + ghcjs-0.2.1.9007019_ghc-8.0.1: + url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz + sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 ``` The later can be generated via: https://github.com/tolysz/prepare-ghcjs -the fromer is a bit more manual. Those bundles are only tested against the latest `node-7.2.1`. +the fromer is a bit more manual. Those bundles are only tested against the latest `node-7.4.0`. In order to corrrectly boot and use ghcjs, one might need to install `alex` `happy` `hscolour` `hsc2hs` with the normal ghc. Older resolvers: -|resolver|url|sha1| -|---|---|---| -| lts-7.13 | http://ghcjs.tolysz.org/ghc-8.0-2016-12-18-lts-7.13-9007013.tar.gz | 530c4ee5e19e2874e128431c7ad421e336df0303 | -| lts-7.8 | http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz | 190300a3725cde44b2a08be9ef829f2077bf8825 | -| lts-7.7 | http://ghcjs.tolysz.org/ghc-8.0-2016-11-03-lts-7.7-9007007.tar.gz | ce169f85f1c49ad613ae77fc494d5565452ff59a | -| lts-7.5 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-24-lts-7.5-9007005.tar.gz | 450e81028d7f1eb82a16bc4b0809f30730c3e173 | -| lts-7.4 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-22-lts-7.4-9007004.tar.gz | ed77b3c15fedbadad5ab0e0afe1bd42c0a8695b4 | -| lts-7.3 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-11-lts-7.3-9007003.tar.gz | 3196fd5eaed670416083cf3678396d02c50096de | -| lts-7.2 | http://ghcjs.tolysz.org/ghc-8.0-2016-10-01-lts-7.2-9007002.tar.gz | a41ae415328e2b257d40724d13d1386390c26322 | -| lts-7.1 | http://ghcjs.tolysz.org/ghc-8.0-2016-09-26-lts-7.1-9007001-mem.tar.gz | e640724883238593e2d2f7f03991cb413ec0347b | -| lts-6.21 | http://ghcjs.tolysz.org/lts-6.21-9006021.tar.gz | 80b83f85dcec182093418e843979f4cee092fa85 | -| lts-6.20 | http://ghcjs.tolysz.org/lts-6.20-9006020.tar.gz | a6cea90cd8121eee3afb201183c6e9bd6bacd94a | -| lts-6.19 | http://ghcjs.tolysz.org/lts-6.19-9006019.tar.gz | ef4264d5a93b269ee4ec8f9d5139da030331d65a | -| lts-6.18 | http://ghcjs.tolysz.org/lts-6.18-9006018.tar.gz | 3e9f345116c851349a5a551ffd94f7e0b74bfabb | +|resolver|ghcjs|url|sha1| +|---|---|---|---| +| lts-7.15 |0.2.1| http://ghcjs.tolysz.org/ghc-8.0-2017-01-11-lts-7.15-9007015.tar.gz | 30d34e9d704bdb799066387dfa1ba98b8884d932 | +| lts-7.14 |0.2.1| http://ghcjs.tolysz.org/ghc-8.0-2016-12-25-lts-7.14-9007014.tar.gz | 530c4ee5e19e2874e128431c7ad421e336df0303 | +| lts-7.13 |0.2.1| http://ghcjs.tolysz.org/ghc-8.0-2016-12-18-lts-7.13-9007013.tar.gz | 0d2ebe0931b29adca7cb9d9b9f77d60095bfb864 | +| lts-7.8 || http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz | 190300a3725cde44b2a08be9ef829f2077bf8825 | +| lts-7.7 || http://ghcjs.tolysz.org/ghc-8.0-2016-11-03-lts-7.7-9007007.tar.gz | ce169f85f1c49ad613ae77fc494d5565452ff59a | +| lts-7.5 || http://ghcjs.tolysz.org/ghc-8.0-2016-10-24-lts-7.5-9007005.tar.gz | 450e81028d7f1eb82a16bc4b0809f30730c3e173 | +| lts-7.4 || http://ghcjs.tolysz.org/ghc-8.0-2016-10-22-lts-7.4-9007004.tar.gz | ed77b3c15fedbadad5ab0e0afe1bd42c0a8695b4 | +| lts-7.3 || http://ghcjs.tolysz.org/ghc-8.0-2016-10-11-lts-7.3-9007003.tar.gz | 3196fd5eaed670416083cf3678396d02c50096de | +| lts-7.2 || http://ghcjs.tolysz.org/ghc-8.0-2016-10-01-lts-7.2-9007002.tar.gz | a41ae415328e2b257d40724d13d1386390c26322 | +| lts-7.1 || http://ghcjs.tolysz.org/ghc-8.0-2016-09-26-lts-7.1-9007001-mem.tar.gz | e640724883238593e2d2f7f03991cb413ec0347b | +| lts-6.25 | 0.2.0 | http://ghcjs.tolysz.org/lts-6.25-9006025.tar.gz | 3c87228579b55c05e227a7876682c2a7d4c9c007 | +| lts-6.21 || http://ghcjs.tolysz.org/lts-6.21-9006021.tar.gz | 80b83f85dcec182093418e843979f4cee092fa85 | +| lts-6.20 || http://ghcjs.tolysz.org/lts-6.20-9006020.tar.gz | a6cea90cd8121eee3afb201183c6e9bd6bacd94a | +| lts-6.19 || http://ghcjs.tolysz.org/lts-6.19-9006019.tar.gz | ef4264d5a93b269ee4ec8f9d5139da030331d65a | +| lts-6.18 || http://ghcjs.tolysz.org/lts-6.18-9006018.tar.gz | 3e9f345116c851349a5a551ffd94f7e0b74bfabb | If you do not use the same resolver, say, an older LTS snapshot, you will get some warnings like this: diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -67,8 +67,8 @@ versions (YMMV). **macOS Sierra warning**: There are new limitations in the dynamic linker that -are causing problems for GHC when building projects with many -dependencies. See +are causing problems for GHC versions earlier than 8.0.2 when building projects with many +dependencies. GHC 8.0.2 is first used in LTS 8.0. See [#2577](https://github.com/commercialhaskell/stack/issues/2577) for more information. @@ -138,6 +138,11 @@ Use the [generic Linux option](#linux). +There is also an unofficial +[Copr repo](https://copr.fedoraproject.org/coprs/petersen/stack/). +Note that this Stack version may lag behind, +so we recommend running `stack upgrade` after installing it. + ## Fedora Use the [generic Linux option](#linux). @@ -177,8 +182,18 @@ ## Arch Linux -Use the [generic Linux option](#linux). +There is an official package in the Arch community repository. So you can +install it by simply doing: + sudo pacman -S stack + +Note that this version may slightly lag behind, but it should be updated within +the day. The package is also always rebuilt and updated when one of it's +dependencies gets an update. + + - [stack](https://www.archlinux.org/packages/community/x86_64/stack/) _latest stable version_ + - [haskell-stack-git](https://aur.archlinux.org/packages/haskell-stack-git/) _git version_ + In order to use `stack setup` with older versions of GHC or on a 32-bit system, you may need the [ncurses5-compat-libs](https://aur.archlinux.org/packages/ncurses5-compat-libs/) @@ -188,13 +203,6 @@ If you use the [ArchHaskell repository](https://wiki.archlinux.org/index.php/ArchHaskell), you can also get the `haskell-stack-tool` package from there. - -There is also an unofficial package in the Arch community repository. Note that this Stack -version may lag behind, so we recommend running `stack upgrade` after installing -it. - - - [stack](https://www.archlinux.org/packages/community/x86_64/stack/) _latest stable version_ - - [haskell-stack-git](https://aur.archlinux.org/packages/haskell-stack-git/) _git version_ ## NixOS diff --git a/doc/nix_integration.md b/doc/nix_integration.md --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -115,6 +115,12 @@ launch themselves in a local build environment (using `nix-shell` behind the scenes). +`stack setup` will start a nix-shell, so it will gather all the required +packages, but given nix handles GHC installation, instead of stack, this will +happen when running `stack build` if no setup has been performed +before. Therefore it is not longer necessary to run `stack setup` unless you +want to cache a GHC installation before running the build. + If `enable:` is omitted or set to `false`, you can still build in a nix-shell by passing the `--nix` flag to stack, for instance `stack --nix build`. Passing any `--nix*` option to the command line will do the same. @@ -125,13 +131,18 @@ ### The Nix shell -By default, stack will run the build in a pure Nix build environment -(or *shell*), which means the build should fail if you haven't -specified all the dependencies in the `packages:` section of the -`stack.yaml` file, even if these dependencies are installed elsewhere -on your system. This behaviour enforces a complete description of the -build environment to facilitate reproducibility. To override this -behaviour, add `pure: false` to your `stack.yaml` or pass the +By default, stack will run the build in a *pure* Nix build environment (or +*shell*), which means two important things: + +- basically **no environment variable will be forwarded** from your user session + to the nix-shell (variables like `HTTP_PROXY` or `PATH` notably will not be + available), +- the build should fail if you haven't specified all the dependencies in the + `packages:` section of the `stack.yaml` file, even if these dependencies are + installed elsewhere on your system. This behaviour enforces a complete + description of the build environment to facilitate reproducibility. + +To override this behaviour, add `pure: false` to your `stack.yaml` or pass the `--no-nix-pure` option to the command line. **Note:** On macOS shells are non-pure by default currently. This is diff --git a/doc/nonstandard_project_init.md b/doc/nonstandard_project_init.md --- a/doc/nonstandard_project_init.md +++ b/doc/nonstandard_project_init.md @@ -36,8 +36,8 @@ manual: true ``` -It is also possible to pass the same flag to multiple packages, i.e. `stack -build --flag *:necessary` +It is also possible to pass the same flag to multiple packages, i.e. +`stack build --flag *:necessary` Currently one needs to list all of your modules that interpret flags in the `other-modules` section of a cabal file. `cabal-install` has a different diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -5,11 +5,11 @@ sometimes *inaccurate*. If you see such cases, please update the page, and if you're not sure how, open an issue labeled "question". -The stack.yaml configuration options break down into [project-specific](#project-config) options in: +The stack.yaml configuration options break down into [project-specific](#project-specific-config) options in: - `/stack.yaml` -and [non-project-specific](#non-project-config) options in: +and [non-project-specific](#non-project-specific-config) options in: - `/etc/stack/config.yaml` -- for system global non-project default options - `~/.stack/config.yaml` -- for user non-project default options @@ -206,8 +206,8 @@ ### image -The image settings are used for the creation of container images using `stack -image container`, e.g. +The image settings are used for the creation of container images using +`stack image container`, e.g. ```yaml image: @@ -321,6 +321,11 @@ # optional fields, both default to false gpg-verify: false require-hashes: false + + # Starting with stack 1.4, we default to using Hackage Security + hackage-security: + keyids: ["deadbeef", "12345"] # list of all approved keys + key-threshold: 3 # number of keys required ``` One thing you should be aware of: if you change the contents of package-version @@ -563,6 +568,11 @@ entropy: false # override the new default for one package ``` +NOTE: since 1.4.0, Stack has support for Cabal's `custom-setup` block +(introduced in Cabal 1.24). If a `custom-setup` block is provided in a `.cabal` +file, it will override the setting of `explicit-setup-deps`, and instead rely +on the stated dependencies. + ### allow-newer (Since 0.1.7) @@ -610,7 +620,10 @@ # NOTE: global usage of haddock can cause build failures when documentation is # incorrectly formatted. This could also affect scripts which use stack. haddock: false - haddock-arguments: "" + haddock-arguments: + haddock-args: [] # Additional arguments passed to haddock, --haddock-arguments + # haddock-args: + # - "--css=/home/user/my-css" open-haddocks: false # --open haddock-deps: false # if unspecified, defaults to true if haddock is set haddock-internal: false @@ -618,11 +631,22 @@ # These are inadvisable to use in your global configuration, as they make the # stack build CLI behave quite differently. test: false - test-arguments: "" + test-arguments: + rerun-tests: true # Rerun successful tests + additional-args: [] # --test-arguments + # additional-args: + # - "--fail-fast" + coverage: false + no-run-tests: false bench: false - benchmark-opts: "" + benchmark-opts: + benchmark-arguments: "" + # benchmark-arguments: "--csv bench.csv" + no-run-benchmarks: false force-dirty: false reconfigure: false + cabal-verbose: false + split-objs: false ``` The meanings of these settings correspond directly with the CLI flags of the @@ -665,8 +689,8 @@ name of the holder of the copyright on the package and the year(s) from which copyright is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` * _github-username_ - used to generate `homepage` and `source-repository` in - cabal. For instance `github-username: myusername` and `stack new my-project - new-template` would result: + cabal. For instance `github-username: myusername` and `stack new my-project new-template` + would result: ```yaml homepage: http://github.com/myusername/my-project#readme @@ -683,7 +707,7 @@ author-name: Your Name author-email: youremail@example.com category: Your Projects Category - copyright: 'Copyright: (c) 2016 Your Name' + copyright: 'Copyright: (c) 2017 Your Name' github-username: yourusername ``` diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- Taken from +-- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client +-- to avoid extra dependencies +module Hackage.Security.Client.Repository.HttpLib.HttpClient ( + withClient + , makeHttpLib + -- ** Re-exports + , Manager -- opaque + ) where + +import Control.Exception +import Control.Monad (void) +import Data.ByteString (ByteString) +import Network.URI +import Network.HTTP.Client (Manager) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.C8 +import qualified Network.HTTP.Client as HttpClient +import qualified Network.HTTP.Client.Internal as HttpClient +import qualified Network.HTTP.Types as HttpClient + +import Hackage.Security.Client hiding (Header) +import Hackage.Security.Client.Repository.HttpLib +import Hackage.Security.Util.Checked +import qualified Hackage.Security.Util.Lens as Lens + +{------------------------------------------------------------------------------- + Top-level API +-------------------------------------------------------------------------------} + +-- | Initialization +-- +-- The proxy must be specified at initialization because @http-client@ does not +-- allow to change the proxy once the 'Manager' is created. +withClient :: ProxyConfig HttpClient.Proxy -> (Manager -> HttpLib -> IO a) -> IO a +withClient proxyConfig callback = do + manager <- HttpClient.newManager (setProxy HttpClient.defaultManagerSettings) + callback manager $ makeHttpLib manager + where + setProxy = HttpClient.managerSetProxy $ + case proxyConfig of + ProxyConfigNone -> HttpClient.noProxy + ProxyConfigUse p -> HttpClient.useProxy p + ProxyConfigAuto -> HttpClient.proxyEnvironment Nothing + +-- | Create an 'HttpLib' value from a preexisting 'Manager'. +makeHttpLib :: Manager -> HttpLib +makeHttpLib manager = HttpLib + { httpGet = get manager + , httpGetRange = getRange manager + } + +{------------------------------------------------------------------------------- + Individual methods +-------------------------------------------------------------------------------} + +get :: Throws SomeRemoteError + => Manager + -> [HttpRequestHeader] -> URI + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +get manager reqHeaders uri callback = wrapCustomEx $ do + -- TODO: setUri fails under certain circumstances; in particular, when + -- the URI contains URL auth. Not sure if this is a concern. + request' <- HttpClient.setUri HttpClient.defaultRequest uri + let request = setRequestHeaders reqHeaders request' + checkHttpException $ HttpClient.withResponse request manager $ \response -> do + let br = wrapCustomEx $ HttpClient.responseBody response + callback (getResponseHeaders response) br + +getRange :: Throws SomeRemoteError + => Manager + -> [HttpRequestHeader] -> URI -> (Int, Int) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +getRange manager reqHeaders uri (from, to) callback = wrapCustomEx $ do + request' <- HttpClient.setUri HttpClient.defaultRequest uri + let request = setRange from to + $ setRequestHeaders reqHeaders request' + checkHttpException $ HttpClient.withResponse request manager $ \response -> do + let br = wrapCustomEx $ HttpClient.responseBody response + case () of + () | HttpClient.responseStatus response == HttpClient.partialContent206 -> + callback HttpStatus206PartialContent (getResponseHeaders response) br + () | HttpClient.responseStatus response == HttpClient.ok200 -> + callback HttpStatus200OK (getResponseHeaders response) br + _otherwise -> + throwChecked $ HttpClient.HttpExceptionRequest request + $ HttpClient.StatusCodeException (void response) "" + +-- | Wrap custom exceptions +-- +-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ +-- but it is currently disabled +wrapCustomEx :: (Throws HttpClient.HttpException => IO a) + -> (Throws SomeRemoteError => IO a) +wrapCustomEx act = handleChecked (\(ex :: HttpClient.HttpException) -> go ex) act + where + go ex = throwChecked (SomeRemoteError ex) + +checkHttpException :: Throws HttpClient.HttpException => IO a -> IO a +checkHttpException = handle $ \(ex :: HttpClient.HttpException) -> + throwChecked ex + +{------------------------------------------------------------------------------- + http-client auxiliary +-------------------------------------------------------------------------------} + +hAcceptRanges :: HttpClient.HeaderName +hAcceptRanges = "Accept-Ranges" + +hAcceptEncoding :: HttpClient.HeaderName +hAcceptEncoding = "Accept-Encoding" + +setRange :: Int -> Int + -> HttpClient.Request -> HttpClient.Request +setRange from to req = req { + HttpClient.requestHeaders = (HttpClient.hRange, rangeHeader) + : HttpClient.requestHeaders req + } + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See + rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) + +-- | Set request headers +setRequestHeaders :: [HttpRequestHeader] + -> HttpClient.Request -> HttpClient.Request +setRequestHeaders opts req = req { + HttpClient.requestHeaders = trOpt disallowCompressionByDefault opts + } + where + trOpt :: [(HttpClient.HeaderName, [ByteString])] + -> [HttpRequestHeader] + -> [HttpClient.Header] + trOpt acc [] = + concatMap finalizeHeader acc + trOpt acc (HttpRequestMaxAge0:os) = + trOpt (insert HttpClient.hCacheControl ["max-age=0"] acc) os + trOpt acc (HttpRequestNoTransform:os) = + trOpt (insert HttpClient.hCacheControl ["no-transform"] acc) os + + -- disable content compression (potential security issue) + disallowCompressionByDefault :: [(HttpClient.HeaderName, [ByteString])] + disallowCompressionByDefault = [(hAcceptEncoding, [])] + + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we we just comma-separate all of them. + finalizeHeader :: (HttpClient.HeaderName, [ByteString]) + -> [HttpClient.Header] + finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] + + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert x y = Lens.modify (Lens.lookupM x) (++ y) + +-- | Extract the response headers +getResponseHeaders :: HttpClient.Response a -> [HttpResponseHeader] +getResponseHeaders response = concat [ + [ HttpResponseAcceptRangesBytes + | (hAcceptRanges, "bytes") `elem` headers + ] + ] + where + headers = HttpClient.responseHeaders response diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -34,9 +34,10 @@ import Control.Monad.IO.Class import Control.Monad.Logger (logDebug, MonadLogger) import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) -import "cryptohash" Crypto.Hash +import Crypto.Hash import Crypto.Hash.Conduit (sinkHash) -import Data.Byteable (toBytes) +import Data.ByteArray as Mem (convert) +import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) import Data.ByteString (ByteString) import Data.ByteString.Char8 (readInteger) import Data.Conduit @@ -153,8 +154,8 @@ sinkCheckHash req HashCheck{..} = do digest <- sinkHashUsing hashCheckAlgorithm let actualDigestString = show digest - let actualDigestHexByteString = digestToHexByteString digest - let actualDigestBytes = toBytes digest + let actualDigestHexByteString = Mem.convertToBase Mem.Base16 digest + let actualDigestBytes = Mem.convert digest let passedCheck = case hashCheckHexDigest of CheckHexDigestString s -> s == actualDigestString diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs --- a/src/Path/Extra.hs +++ b/src/Path/Extra.hs @@ -7,6 +7,7 @@ ,dropRoot ,parseCollapsedAbsDir ,parseCollapsedAbsFile + ,concatAndColapseAbsDir ,rejectMissingFile ,rejectMissingDir ,pathToByteString @@ -42,6 +43,12 @@ -- (probably should be moved to the Path module) parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) parseCollapsedAbsFile = parseAbsFile . collapseFilePath + +-- | Add a relative FilePath to the end of a Path +-- We can't parse the FilePath first because we need to account for ".." +-- in the FilePath (#2895) +concatAndColapseAbsDir :: MonadThrow m => Path Abs Dir -> FilePath -> m (Path Abs Dir) +concatAndColapseAbsDir base rel = parseCollapsedAbsDir (toFilePath base FP. rel) -- | Collapse intermediate "." and ".." directories from a path. -- diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -24,7 +24,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Resource import Control.Monad.Trans.Unlift (MonadBaseUnlift) import Data.Aeson (Value (Object, Array), (.=), object) @@ -92,14 +92,15 @@ -> BuildOptsCLI -> m () build setLocalFiles mbuildLk boptsCli = fixCodePage $ do - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL let profiling = boptsLibProfile bopts || boptsExeProfile bopts + let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) menv <- getMinimalEnvOverride - (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli + (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull True NeedTargets boptsCli -- Set local files, necessary for file watching - stackYaml <- asks $ bcStackYaml . getBuildConfig + stackYaml <- view stackYamlL liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions @@ -109,7 +110,8 @@ getInstalled menv GetInstalledOpts { getInstalledProfiling = profiling - , getInstalledHaddock = shouldHaddockDeps bopts } + , getInstalledHaddock = shouldHaddockDeps bopts + , getInstalledSymbols = symbols } sourceMap warnMissingExtraDeps installedMap extraDeps @@ -118,6 +120,11 @@ 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 @@ -153,10 +160,17 @@ 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 <- asks (configAllowNewer . getConfig) - cabalVer <- asks (envConfigCabalVersion . getEnvConfig) + allowNewer <- view $ configL.to configAllowNewer + cabalVer <- view cabalVersionL -- https://github.com/haskell/cabal/issues/2023 when (allowNewer && cabalVer < $(mkVersion "1.22")) $ throwM $ CabalVersionException $ @@ -164,7 +178,7 @@ versionString cabalVer ++ " was found." -data CabalVersionException = CabalVersionException { unCabalVersionException :: String } +newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String } deriving (Typeable) instance Show CabalVersionException where show = unCabalVersionException @@ -280,7 +294,7 @@ mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => BuildOptsCLI -> m BaseConfigOpts mkBaseConfigOpts boptsCli = do - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal snapInstallRoot <- installationRootDeps @@ -302,7 +316,7 @@ -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) -> m a withLoadPackage menv inner = do - econfig <- asks getEnvConfig + econfig <- view envConfigL withCabalLoader menv $ \cabalLoader -> inner $ \name version flags ghcOptions -> do bs <- cabalLoader $ PackageIdentifier name version @@ -320,8 +334,8 @@ , packageConfigEnableBenchmarks = False , packageConfigFlags = flags , packageConfigGhcOptions = ghcOptions - , packageConfigCompilerVersion = envConfigCompilerVersion econfig - , packageConfigPlatform = configPlatform (getConfig econfig) + , packageConfigCompilerVersion = view actualCompilerVersionL econfig + , packageConfigPlatform = view platformL econfig } -- | Set the code page for this process as necessary. Only applies to Windows. @@ -329,9 +343,9 @@ #ifdef WINDOWS fixCodePage :: (StackM env m, HasBuildConfig env, HasEnvConfig env) => m a -> m a fixCodePage inner = do - mcp <- asks $ configModifyCodePage . getConfig - ec <- asks getEnvConfig - if mcp && getGhcVersion (envConfigCompilerVersion ec) < $(mkVersion "7.10.3") + mcp <- view $ configL.to configModifyCodePage + ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion + if mcp && ghcVersion < $(mkVersion "7.10.3") then fixCodePage' -- GHC >=7.10.3 doesn't need this code page hack. else inner @@ -349,7 +363,7 @@ (liftIO $ setConsoleCP origCPI) | otherwise = id fixOutput - | setInput = Catch.bracket_ + | setOutput = Catch.bracket_ (liftIO $ do setConsoleOutputCP expected) (liftIO $ setConsoleOutputCP origCPO) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -38,14 +38,15 @@ import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger, logDebug) -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Crypto.Hash.SHA256 as SHA256 +import Crypto.Hash (hashWith, SHA256(..)) import Data.Binary (Binary (..)) import qualified Data.Binary as Binary import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion) import qualified Data.Binary.Tagged as BinaryTagged -import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteArray as Mem (convert) +import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS @@ -251,10 +252,10 @@ -> Set GhcPkgId -- ^ dependencies -> m (Path Abs File, m (Path Abs File)) precompiledCacheFile pkgident copts installedPackageIDs = do - ec <- asks getEnvConfig + ec <- view envConfigL - compiler <- parseRelDir $ compilerVersionString $ envConfigCompilerVersion ec - cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec + compiler <- view actualCompilerVersionL >>= parseRelDir . compilerVersionString + cabal <- view cabalVersionL >>= parseRelDir . versionString pkg <- parseRelDir $ packageIdentifierString pkgident platformRelDir <- platformGhcRelDir @@ -265,13 +266,13 @@ -- Unfortunately, earlier Cabals don't have the information, so we must -- supplement it with the installed package IDs directly. -- See issue: https://github.com/commercialhaskell/stack/issues/1103 - let oldHash = B16.encode $ SHA256.hash $ LBS.toStrict $ - if envConfigCabalVersion ec >= $(mkVersion "1.22") + let oldHash = Mem.convertToBase Mem.Base16 $ hashWith SHA256 $ LBS.toStrict $ + if view cabalVersionL ec >= $(mkVersion "1.22") then Binary.encode (coNoDirs copts) else Binary.encode input hashToPath hash = do hashPath <- parseRelFile $ S8.unpack hash - return $ getStackRoot ec + return $ view stackRootL ec $(mkRelDir "precompiled") platformRelDir compiler @@ -280,7 +281,7 @@ hashPath $logDebug $ "Precompiled cache input = " <> T.pack (show input) - newPath <- hashToPath $ B64URL.encode $ SHA256.hash $ Store.encode input + newPath <- hashToPath $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ Store.encode input return (newPath, hashToPath oldHash) -- | Write out information about a newly built package @@ -295,8 +296,8 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do (file, _) <- precompiledCacheFile pkgident copts depIDs ensureDir (parent file) - ec <- asks getEnvConfig - let stackRootRelative = makeRelative (getStackRoot ec) + ec <- view envConfigL + let stackRootRelative = makeRelative (view stackRootL ec) mlibpath <- case mghcPkgId of Executable _ -> return Nothing @@ -321,11 +322,11 @@ -> Set GhcPkgId -- ^ dependencies -> m (Maybe PrecompiledCache) readPrecompiledCache pkgident copts depIDs = do - ec <- asks getEnvConfig + ec <- view envConfigL let toAbsPath path = do if FilePath.isAbsolute path then path -- Only older version store absolute path - else toFilePath (getStackRoot ec) FilePath. path + else toFilePath (view stackRootL ec) FilePath. path let toAbsPC pc = PrecompiledCache { pcLibrary = fmap toAbsPath (pcLibrary pc) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -15,12 +15,12 @@ ( constructPlan ) where -import Control.Arrow ((&&&)) import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.RWS.Strict +import Control.Monad.State.Strict (execState) import Control.Monad.Trans.Resource import Data.Either import Data.Function @@ -42,6 +42,7 @@ import qualified Distribution.Version as Cabal import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Lens.Micro (lens) import Path import Prelude hiding (pi, writeFile) import Stack.Build.Cache @@ -136,31 +137,28 @@ , logFunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO () } -instance HasStackRoot Ctx instance HasPlatform Ctx instance HasGHCVariant Ctx instance HasConfig Ctx -instance HasBuildConfig Ctx where - getBuildConfig = getBuildConfig . getEnvConfig +instance HasBuildConfig Ctx instance HasEnvConfig Ctx where - getEnvConfig = ctxEnvConfig + envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) constructPlan :: forall env m. (StackM env m, HasEnvConfig env) => MiniBuildPlan -> BaseConfigOpts -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built - -> [DumpPackage () ()] -- ^ locally registered + -> [DumpPackage () () ()] -- ^ locally registered -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> m Plan constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do $logDebug "Constructing the build plan" - let locallyRegistered = Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localDumpPkgs getVersions0 <- getPackageVersionsIO - econfig <- asks getEnvConfig + econfig <- view envConfigL let onWanted = void . addDep False . packageName . lpPackage let inner = do mapM_ onWanted $ filter lpWanted locals @@ -187,7 +185,7 @@ return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals - , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap + , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap , planInstallExes = if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 then installExes @@ -195,7 +193,8 @@ } else do planDebug $ show errs - $prettyError $ pprintExceptions errs (bcStackYaml (getBuildConfig econfig)) parents (wantedLocalPackages locals) + stackYaml <- view stackYamlL + $prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals) throwM $ ConstructPlanFailed "Plan construction failed." where ctx econfig getVersions0 lf = Ctx @@ -219,30 +218,79 @@ -- or local packages. toolMap = getToolMap mbp0 +-- | State to be maintained during the calculation of local packages +-- to unregister. +data UnregisterState = UnregisterState + { usToUnregister :: !(Map GhcPkgId (PackageIdentifier, Text)) + , usKeep :: ![DumpPackage () () ()] + , usAnyAdded :: !Bool + } + -- | Determine which packages to unregister based on the given tasks and -- already registered local packages mkUnregisterLocal :: Map PackageName Task + -- ^ Tasks -> Map PackageName Text - -> Map GhcPkgId PackageIdentifier + -- ^ Reasons why packages are dirty and must be rebuilt + -> [DumpPackage () () ()] + -- ^ Local package database dump -> SourceMap - -> Map GhcPkgId (PackageIdentifier, Maybe Text) -mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap = - Map.unions $ map toUnregisterMap $ Map.toList locallyRegistered + -> Map GhcPkgId (PackageIdentifier, Text) +mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap = + -- We'll take multiple passes through the local packages. This + -- will allow us to detect that a package should be unregistered, + -- as well as all packages directly or transitively depending on + -- it. + loop Map.empty localDumpPkgs where - toUnregisterMap (gid, ident) = - case M.lookup name tasks of - Nothing -> - case M.lookup name sourceMap of - Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid - ( ident - , Just "Switching to snapshot installed package" - ) - _ -> Map.empty - Just _ -> Map.singleton gid - ( ident - , Map.lookup name dirtyReason - ) + loop toUnregister keep + -- If any new packages were added to the unregister Map, we + -- need to loop through the remaining packages again to detect + -- if a transitive dependency is being unregistered. + | usAnyAdded us = loop (usToUnregister us) (usKeep us) + -- Nothing added, so we've already caught them all. Return the + -- Map we've already calculated. + | otherwise = usToUnregister us where + -- Run the unregister checking function on all packages we + -- currently think we'll be keeping. + us = execState (mapM_ go keep) UnregisterState + { usToUnregister = toUnregister + , usKeep = [] + , usAnyAdded = False + } + + go dp = do + us <- get + case go' (usToUnregister us) ident deps of + -- Not unregistering, add it to the keep list + Nothing -> put us { usKeep = dp : usKeep us } + -- Unregistering, add it to the unregister Map and + -- indicate that a package was in fact added to the + -- unregister Map so we loop again. + Just reason -> put us + { usToUnregister = Map.insert gid (ident, reason) (usToUnregister us) + , usAnyAdded = True + } + where + gid = dpGhcPkgId dp + ident = dpPackageIdent dp + deps = dpDepends dp + + go' toUnregister ident deps + -- If we're planning on running a task on it, then it must be + -- unregistered + | Just _ <- Map.lookup name tasks + = Just $ fromMaybe "" $ Map.lookup name dirtyReason + -- Check if we're no longer using the local version + | Just (PSUpstream _ Snap _ _ _) <- Map.lookup name sourceMap + = Just "Switching to snapshot installed package" + -- Check if a dependency is going to be unregistered + | (dep, _):_ <- mapMaybe (`Map.lookup` toUnregister) deps + = Just $ "Dependency being unregistered: " <> packageIdentifierText dep + -- None of the above, keep it! + | otherwise = Nothing + where name = packageIdentifierName ident addFinal :: LocalPackage -> Package -> Bool -> M () @@ -259,7 +307,7 @@ , taskConfigOpts = TaskConfigOpts missing $ \missing' -> let allDeps = Map.union present missing' in configureOpts - (getEnvConfig ctx) + (view envConfigL ctx) (baseConfigOpts ctx) allDeps True -- local @@ -440,7 +488,7 @@ let allDeps = Map.union present missing' destLoc = piiLocation ps <> minLoc in configureOpts - (getEnvConfig ctx) + (view envConfigL ctx) (baseConfigOpts ctx) allDeps (psLocal ps) @@ -506,7 +554,7 @@ , " requires: " , versionRangeText range ] - allowNewer <- asks $ configAllowNewer . getConfig + allowNewer <- view $ configL.to configAllowNewer if allowNewer then do warn_ " (allow-newer enabled)" @@ -552,7 +600,7 @@ ctx <- ask moldOpts <- flip runLoggingT (logFunc ctx) $ tryGetFlagCache installed let configOpts = configureOpts - (getEnvConfig ctx) + (view envConfigL ctx) (baseConfigOpts ctx) present (psLocal ps) @@ -580,7 +628,7 @@ | Just files <- psDirty ps -> Just $ "local file changes: " <> addEllipsis (T.pack $ unwords $ Set.toList files) | otherwise -> Nothing - config = getConfig ctx + config = view configL ctx case mreason of Nothing -> return False Just reason -> do @@ -678,7 +726,7 @@ let toolName = case warning of NoToolFound tool _ -> tool AmbiguousToolsFound tool _ _ -> tool - config <- asks getConfig + config <- view configL menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True } mfound <- findExecutable menv toolName case mfound of diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -30,11 +30,11 @@ import Control.Monad.Extra (anyM, (&&^)) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource -import qualified Crypto.Hash.SHA256 as SHA256 +import Crypto.Hash import Data.Attoparsec.Text hiding (try) +import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import Data.Char (isSpace) @@ -65,6 +65,7 @@ import Data.Traversable (forM) import Data.Tuple import qualified Distribution.PackageDescription as C +import qualified Distribution.Simple.Build.Macros as C import Distribution.System (OS (Windows), Platform (Platform)) import qualified Distribution.Text as C @@ -139,11 +140,11 @@ [] -> $logInfo "No packages would be unregistered." xs -> do $logInfo "Would unregister locally:" - forM_ xs $ \(ident, mreason) -> $logInfo $ T.concat + forM_ xs $ \(ident, reason) -> $logInfo $ T.concat [ T.pack $ packageIdentifierString ident - , case mreason of - Nothing -> "" - Just reason -> T.concat + , if T.null reason + then "" + else T.concat [ " (" , reason , ")" @@ -226,9 +227,9 @@ , eeWanted :: !(Set PackageName) , eeLocals :: ![LocalPackage] , eeGlobalDB :: !(Path Abs Dir) - , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ())) - , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ()))) - , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ()))) + , eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () () ())) + , eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) + , eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () () ()))) , eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File)) } @@ -255,7 +256,7 @@ simpleSetupHash :: String simpleSetupHash = - T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ SHA256.hash $ + T.unpack $ decodeUtf8 $ S.take 8 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 (T.pack (unwords buildSetupArgs)) <> setupGhciShimCode <> simpleSetupCode -- | Get a compiled Setup exe @@ -265,20 +266,22 @@ -> Path Abs Dir -- ^ temporary directory -> m (Maybe (Path Abs File)) getSetupExe setupHs setupShimHs tmpdir = do - wc <- getWhichCompiler - econfig <- asks getEnvConfig + wc <- view $ actualCompilerVersionL.whichCompilerL platformDir <- platformGhcRelDir - let config = getConfig econfig - baseNameS = concat + config <- view configL + cabalVersionString <- view $ cabalVersionL.to versionString + actualCompilerVersionString <- view $ actualCompilerVersionL.to compilerVersionString + platform <- view platformL + let baseNameS = concat [ "Cabal-simple_" , simpleSetupHash , "_" - , versionString $ envConfigCabalVersion econfig + , cabalVersionString , "_" - , compilerVersionString $ envConfigCompilerVersion econfig + , actualCompilerVersionString ] exeNameS = baseNameS ++ - case configPlatform config of + case platform of Platform _ Windows -> ".exe" _ -> "" outputNameS = @@ -307,7 +310,7 @@ menv <- getMinimalEnvOverride let args = buildSetupArgs ++ [ "-package" - , "Cabal-" ++ versionString (envConfigCabalVersion econfig) + , "Cabal-" ++ cabalVersionString , toFilePath setupHs , toFilePath setupShimHs , "-o" @@ -326,9 +329,9 @@ -> BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] - -> [DumpPackage () ()] -- ^ global packages - -> [DumpPackage () ()] -- ^ snapshot packages - -> [DumpPackage () ()] -- ^ local packages + -> [DumpPackage () () ()] -- ^ global packages + -> [DumpPackage () () ()] -- ^ snapshot packages + -> [DumpPackage () () ()] -- ^ local packages -> (ExecuteEnv -> m a) -> m a withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do @@ -336,7 +339,7 @@ configLock <- newMVar () installLock <- newMVar () idMap <- liftIO $ newTVarIO Map.empty - config <- asks (getConfig . getEnvConfig) + config <- view configL -- Create files for simple setup and setup shim, if necessary let setupSrcDir = @@ -353,8 +356,8 @@ unless setupShimHsExists $ liftIO $ S.writeFile (toFilePath setupShimHs) setupGhciShimCode setupExe <- getSetupExe setupHs setupShimHs tmpdir - cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) - globalDB <- getGlobalDB menv =<< getWhichCompiler + cabalPkgVer <- view cabalVersionL + globalDB <- getGlobalDB menv =<< view (actualCompilerVersionL.whichCompilerL) snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages) localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) logFilesTChan <- liftIO $ atomically newTChan @@ -394,7 +397,7 @@ -- No log files generated, nothing to dump [] -> return () firstLog:_ -> do - toDump <- asks (configDumpLogs . getConfig) + toDump <- view $ configL.to configDumpLogs case toDump of DumpAllLogs -> mapM_ (dumpLog "") allLogs DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs @@ -426,7 +429,8 @@ =$ CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) - isWarning t = ": Warning:" `T.isSuffixOf` t + isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8 + || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different dumpLog msgSuffix (pkgDir, filepath) = do $logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] @@ -443,27 +447,27 @@ -> BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] - -> [DumpPackage () ()] -- ^ global packages - -> [DumpPackage () ()] -- ^ snapshot packages - -> [DumpPackage () ()] -- ^ local packages + -> [DumpPackage () () ()] -- ^ global packages + -> [DumpPackage () () ()] -- ^ snapshot packages + -> [DumpPackage () () ()] -- ^ local packages -> InstalledMap -> Map PackageName SimpleTarget -> Plan -> m () executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do $logDebug "Executing the build plan" - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) unless (Map.null $ planInstallExes plan) $ do snapBin <- ( bindirSuffix) `liftM` installationRootDeps localBin <- ( bindirSuffix) `liftM` installationRootLocal - destDir <- asks $ configLocalBin . getConfig + destDir <- view $ configL.to configLocalBin ensureDir destDir destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir - platform <- asks getPlatform + platform <- view platformL let ext = case platform of Platform _ Windows -> ".exe" @@ -550,7 +554,7 @@ , " not found on the PATH environment variable" ] - config <- asks getConfig + config <- view configL menv' <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = True , esIncludeGhcPackagePath = True @@ -581,19 +585,19 @@ -> m () executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports - wc <- getWhichCompiler - cv <- asks $ envConfigCompilerVersion . getEnvConfig + cv <- view actualCompilerVersionL + let wc = view whichCompilerL cv case Map.toList $ planUnregisterLocal plan of [] -> return () ids -> do localDB <- packageDatabaseLocal - forM_ ids $ \(id', (ident, mreason)) -> do + forM_ ids $ \(id', (ident, reason)) -> do $logInfo $ T.concat [ T.pack $ packageIdentifierString ident , ": unregistering" - , case mreason of - Nothing -> "" - Just reason -> T.concat + , if T.null reason + then "" + else T.concat [ " (" , reason , ")" @@ -616,8 +620,8 @@ (fmap (\f -> (Nothing, Just f))) (planTasks plan) (planFinals plan) - threads <- asks $ configJobs . getConfig - concurrentTests <- asks $ configConcurrentTests . getConfig + threads <- view $ configL.to configJobs + concurrentTests <- view $ configL.to configConcurrentTests let keepGoing = fromMaybe (boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts) (boptsKeepGoing eeBuildOpts) concurrentFinal = @@ -627,7 +631,7 @@ if boptsTests eeBuildOpts then concurrentTests else True - terminal <- asks getTerminal + terminal <- view terminalL errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do let total = length actions loop prev @@ -727,7 +731,7 @@ => ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool -> m (Map PackageIdentifier GhcPkgId, ConfigCache) getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do - useExactConf <- asks (configAllowNewer . getConfig) + useExactConf <- view $ configL.to configAllowNewer let extra = -- We enable tests if the test suite dependencies are already -- installed, so that we avoid unnecessary recompilation based on @@ -900,7 +904,7 @@ $ \h -> inner (Just (logPath, h)) withCabal package pkgDir mlogFile inner = do - config <- asks getConfig + config <- view configL unless (configAllowDifferentUser config) $ checkOwnership (pkgDir configWorkDir config) @@ -932,29 +936,71 @@ ["-package=" ++ packageIdentifierString (PackageIdentifier cabalPackageName eeCabalPkgVer)] - packageArgs = - case mdeps of + packageDBArgs = + ( "-clear-package-db" + : "-global-package-db" + : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) + ) ++ + ( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)) + : ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts)) + : ["-hide-all-packages"] + ) + + getPackageArgs setupDir = + case (packageSetupDeps package, mdeps) of + -- The package is using the Cabal custom-setup + -- configuration introduced in Cabal 1.24. In + -- this case, the package is providing an + -- explicit list of dependencies, and we + -- should simply use all of them. + (Just customSetupDeps, _) -> do + allDeps <- + case mdeps of + Just x -> return x + Nothing -> do + $logWarn "In getPackageArgs: custom-setup in use, but no dependency map present" + return Map.empty + matchedDeps <- forM (Map.toList customSetupDeps) $ \(name, range) -> do + let matches (PackageIdentifier name' version) = + name == name' && + version `withinRange` range + case filter (matches . fst) (Map.toList allDeps) of + x:xs -> do + unless (null xs) + ($logWarn (T.pack ("Found multiple installed packages for custom-setup dep: " ++ packageNameString name))) + return ("-package-id=" ++ ghcPkgIdString (snd x), Just (toCabalPackageIdentifier (fst x))) + [] -> do + $logWarn (T.pack ("Could not find custom-setup dep: " ++ packageNameString name)) + return ("-package=" ++ packageNameString name, Nothing) + let depsArgs = map fst matchedDeps + -- Generate setup_macros.h and provide it to ghc + let macroDeps = mapMaybe snd matchedDeps + cppMacrosFile = toFilePath $ setupDir $(mkRelFile "setup_macros.h") + cppArgs = ["-optP-include", "-optP" ++ cppMacrosFile] + liftIO $ S.writeFile cppMacrosFile (encodeUtf8 (T.pack (C.generatePackageVersionMacros macroDeps))) + return (packageDBArgs ++ depsArgs ++ cppArgs) + -- This branch is taken when -- 'explicit-setup-deps' is requested in your -- stack.yaml file. - Just deps | explicitSetupDeps (packageName package) config -> + (Nothing, Just deps) | explicitSetupDeps (packageName package) config -> do + $logWarn $ T.pack $ concat + [ "Package " + , packageNameString $ packageName package + , " uses a custom Cabal build, but does not use a custom-setup stanza" + ] + $logWarn "Using the explicit setup deps approach based on configuration" + $logWarn "Strongly recommend fixing the package's cabal file" -- Stack always builds with the global Cabal for various -- reproducibility issues. let depsMinusCabal = map ghcPkgIdString $ Set.toList $ addGlobalPackages deps (Map.elems eeGlobalDumpPkgs) - in - ( "-clear-package-db" - : "-global-package-db" - : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) - ) ++ - ( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)) - : ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts)) - : ["-hide-all-packages"] - ) ++ + return ( + packageDBArgs ++ cabalPackageArg ++ - map ("-package-id=" ++) depsMinusCabal + map ("-package-id=" ++) depsMinusCabal) -- This branch is usually taken for builds, and -- is always taken for `stack sdist`. -- @@ -972,12 +1018,23 @@ -- Currently, this branch is only taken via `stack -- sdist` or when explicitly requested in the -- stack.yaml file. - _ -> - cabalPackageArg ++ - ("-clear-package-db" - : "-global-package-db" - : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) - ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) + (Nothing, _) -> do + $logWarn $ T.pack $ concat + [ "Package " + , packageNameString $ packageName package + , " uses a custom Cabal build, but does not use a custom-setup stanza" + ] + $logWarn "Not using the explicit setup deps approach based on configuration" + $logWarn "Strongly recommend fixing the package's cabal file" + return $ cabalPackageArg ++ + -- NOTE: This is different from + -- packageDBArgs above in that it does not + -- include the local database and does not + -- pass in the -hide-all-packages argument + ("-clear-package-db" + : "-global-package-db" + : map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts) + ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args runExe exeName fullArgs = @@ -1014,7 +1071,7 @@ -- If users want control, we should add a config option for this makeAbsolute = stripTHLoading - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.whichCompilerL (exeName, fullArgs) <- case (esetupexehs, wc) of (Left setupExe, _) -> return (setupExe, setupArgs) (Right setuphs, compiler) -> do @@ -1026,6 +1083,7 @@ case compiler of Ghc -> getGhcPath Ghcjs -> getGhcjsPath + packageArgs <- getPackageArgs setupDir runExe compilerPath $ [ "--make" , "-odir", toFilePathNoTrailingSep setupDir @@ -1120,7 +1178,7 @@ _ -> return Nothing copyPreCompiled (PrecompiledCache mlib exes) = do - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.whichCompilerL announceTask task "using precompiled package" forM_ mlib $ \libpath -> do menv <- getMinimalEnvOverride @@ -1202,7 +1260,7 @@ cabal False ["repl", "stack-initial-build-steps"] realBuild cache package pkgDir cabal announce = do - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.whichCompilerL markExeNotInstalled (taskLocation task) taskProvides case taskType of @@ -1238,7 +1296,7 @@ "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems." () <- announce ("build" <> annSuffix) - config <- asks getConfig + config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of @@ -1271,7 +1329,8 @@ cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,sourceFlag, ["--internal" | boptsHaddockInternal eeBuildOpts]]) - unless isFinalBuild $ withMVar eeInstallLock $ \() -> do + let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package))) + when shouldCopy $ withMVar eeInstallLock $ \() -> do announce "copy/register" eres <- try $ cabal False ["copy"] case eres of @@ -1355,7 +1414,7 @@ -- fullblown 'withSingleContext'. (allDepsMap, _cache) <- getConfigCache ee task installedMap True False withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do - config <- asks getConfig + config <- view configL let needHpc = toCoverage topts toRun <- @@ -1641,7 +1700,7 @@ -- -- * https://github.com/commercialhaskell/stack/issues/949 addGlobalPackages :: Map PackageIdentifier GhcPkgId -- ^ dependencies of the package - -> [DumpPackage () ()] -- ^ global packages + -> [DumpPackage () () ()] -- ^ global packages -> Set GhcPkgId addGlobalPackages deps globals0 = res diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -122,7 +122,7 @@ => EnvOverride -> WhichCompiler -> BaseConfigOpts - -> Map GhcPkgId (DumpPackage () ()) -- ^ Local package dump + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local package dump -> [LocalPackage] -> m () generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do @@ -148,9 +148,9 @@ => EnvOverride -> WhichCompiler -> BaseConfigOpts - -> Map GhcPkgId (DumpPackage () ()) -- ^ Global dump information - -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot dump information - -> Map GhcPkgId (DumpPackage () ()) -- ^ Local dump information + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global dump information + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot dump information + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local dump information -> [LocalPackage] -> m () generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do @@ -193,8 +193,8 @@ => EnvOverride -> WhichCompiler -> BaseConfigOpts - -> Map GhcPkgId (DumpPackage () ()) -- ^ Global package dump - -> Map GhcPkgId (DumpPackage () ()) -- ^ Snapshot package dump + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global package dump + -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot package dump -> m () generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex @@ -213,7 +213,7 @@ -> EnvOverride -> WhichCompiler -> HaddockOpts - -> [DumpPackage () ()] + -> [DumpPackage () () ()] -> FilePath -> Path Abs Dir -> m () @@ -228,20 +228,25 @@ Left _ -> True Right indexModTime -> or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] - when needUpdate $ do - $logInfo - (T.concat ["Updating Haddock index for ", descr, " in\n", - T.pack (toFilePath destIndexFile)]) - liftIO (mapM_ copyPkgDocs interfaceOpts) - readProcessNull - (Just destDir) - envOverride - (haddockExeName wc) - (hoAdditionalArgs hdopts ++ - ["--gen-contents", "--gen-index"] ++ - [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) + if needUpdate + then do + $logInfo + (T.concat ["Updating Haddock index for ", descr, " in\n", + T.pack (toFilePath destIndexFile)]) + liftIO (mapM_ copyPkgDocs interfaceOpts) + readProcessNull + (Just destDir) + envOverride + (haddockExeName wc) + (hoAdditionalArgs hdopts ++ + ["--gen-contents", "--gen-index"] ++ + [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) + else + $logInfo + (T.concat ["Haddock index for ", descr, " already up to date at:\n", + T.pack (toFilePath destIndexFile)]) where - toInterfaceOpt :: DumpPackage a b -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) + toInterfaceOpt :: DumpPackage a b c -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) toInterfaceOpt DumpPackage {..} = case dpHaddockInterfaces of [] -> return Nothing @@ -294,8 +299,8 @@ -- | Find first DumpPackage matching the GhcPkgId lookupDumpPackage :: GhcPkgId - -> [Map GhcPkgId (DumpPackage () ())] - -> Maybe (DumpPackage () ()) + -> [Map GhcPkgId (DumpPackage () () ())] + -> Maybe (DumpPackage () () ()) lookupDumpPackage ghcPkgId dumpPkgs = listToMaybe $ mapMaybe (Map.lookup ghcPkgId) dumpPkgs diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -- Determine which packages are already installed module Stack.Build.Installed @@ -15,7 +15,6 @@ import Control.Arrow import Control.Monad import Control.Monad.Logger -import Control.Monad.Reader (asks) import Data.Conduit import qualified Data.Conduit.List as CL import qualified Data.Foldable as F @@ -52,6 +51,8 @@ -- ^ Require profiling libraries? , getInstalledHaddock :: !Bool -- ^ Require haddocks? + , getInstalledSymbols :: !Bool + -- ^ Require debugging symbols? } -- | Returns the new InstalledMap and all of the locally registered packages. @@ -60,9 +61,9 @@ -> GetInstalledOpts -> Map PackageName pii -- ^ does not contain any installed information -> m ( InstalledMap - , [DumpPackage () ()] -- globally installed - , [DumpPackage () ()] -- snapshot installed - , [DumpPackage () ()] -- locally installed + , [DumpPackage () () ()] -- globally installed + , [DumpPackage () () ()] -- snapshot installed + , [DumpPackage () () ()] -- locally installed ) getInstalled menv opts sourceMap = do $logDebug "Finding out which packages are already installed" @@ -70,11 +71,9 @@ localDBPath <- packageDatabaseLocal extraDBPaths <- packageDatabaseExtra - bconfig <- asks getBuildConfig - mcache <- if getInstalledProfiling opts || getInstalledHaddock opts - then liftM Just $ loadInstalledCache $ configInstalledCache bconfig + then configInstalledCache >>= liftM Just . loadInstalledCache else return Nothing let loadDatabase' = loadDatabase menv opts mcache sourceMap @@ -90,7 +89,9 @@ loadDatabase' (Just (InstalledTo Local, localDBPath)) installedLibs2 let installedLibs = M.fromList $ map lhPair installedLibs3 - F.forM_ mcache (saveInstalledCache (configInstalledCache bconfig)) + F.forM_ mcache $ \cache -> do + icache <- configInstalledCache + saveInstalledCache icache cache -- Add in the executables that are installed, making sure to only trust a -- listed installation under the right circumstances (see below) @@ -132,9 +133,9 @@ -> Map PackageName pii -- ^ to determine which installed things we should include -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases - -> m ([LoadHelper], [DumpPackage () ()]) + -> m ([LoadHelper], [DumpPackage () () ()]) loadDatabase menv opts mcache sourceMap mdb lhs0 = do - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.to whichCompiler (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) $ conduitDumpPackage =$ sink let ghcjsHack = wc == Ghcjs && isNothing mdb @@ -159,11 +160,18 @@ -- Just an optimization to avoid calculating the haddock -- values when they aren't necessary _ -> CL.map (\dp -> dp { dpHaddock = False }) + conduitSymbolsCache = + case mcache of + Just cache | getInstalledSymbols opts -> addSymbols cache + -- Just an optimization to avoid calculating the debugging + -- symbol values when they aren't necessary + _ -> CL.map (\dp -> dp { dpSymbols = False }) mloc = fmap fst mdb sinkDP = conduitProfilingCache - =$ conduitHaddockCache - =$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) - =$ CL.consume + =$ conduitHaddockCache + =$ conduitSymbolsCache + =$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) + =$ CL.consume sink = getZipSink $ (,) <$> ZipSink sinkDP <*> ZipSink CL.consume @@ -198,6 +206,7 @@ Allowed -> " the impossible?!?!" NeedsProfiling -> " it needing profiling." NeedsHaddock -> " it needing haddocks." + NeedsSymbols -> " it needing debugging symbols." UnknownPkg -> " it being unknown to the resolver / extra-deps." WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc)) WrongVersion actual wanted -> T.concat @@ -213,6 +222,7 @@ = Allowed | NeedsProfiling | NeedsHaddock + | NeedsSymbols | UnknownPkg | WrongLocation (Maybe InstalledPackageLocation) InstallLocation | WrongVersion Version Version @@ -226,13 +236,15 @@ -> Maybe InstalledCache -> Map PackageName pii -> Maybe InstalledPackageLocation - -> DumpPackage Bool Bool + -> DumpPackage Bool Bool Bool -> Allowed isAllowed opts mcache sourceMap mloc dp -- Check that it can do profiling if necessary | getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = NeedsProfiling -- Check that it has haddocks if necessary | getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = NeedsHaddock + -- Check that it has haddocks if necessary + | getInstalledSymbols opts && isJust mcache && not (dpSymbols dp) = NeedsSymbols | otherwise = case Map.lookup name sourceMap of Nothing -> @@ -263,7 +275,7 @@ } deriving Show -toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool -> LoadHelper +toLoadHelper :: Maybe InstalledPackageLocation -> DumpPackage Bool Bool Bool -> LoadHelper toLoadHelper mloc dp = LoadHelper { lhId = gid , lhDeps = diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -29,12 +29,12 @@ import Control.Monad hiding (sequence) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Resource -import "cryptohash" Crypto.Hash (Digest, SHA256) +import Crypto.Hash (Digest, SHA256(..)) import Crypto.Hash.Conduit (sinkHash) +import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S -import Data.Byteable (toBytes) import Data.Conduit (($$), ZipSink (..)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL @@ -88,11 +88,12 @@ , SourceMap ) loadSourceMap needTargets boptsCli = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull needTargets boptsCli + (_, _, locals, _, _, sourceMap) <- loadSourceMapFull True needTargets boptsCli return (locals, sourceMap) loadSourceMapFull :: (StackM env m, HasEnvConfig env) - => NeedTargets + => Bool + -> NeedTargets -> BuildOptsCLI -> m ( Map PackageName SimpleTarget , MiniBuildPlan @@ -101,8 +102,8 @@ , Map PackageName Version -- extra-deps from configuration and cli , SourceMap ) -loadSourceMapFull needTargets boptsCli = do - bconfig <- asks getBuildConfig +loadSourceMapFull omitWiredIn needTargets boptsCli = do + bconfig <- view buildConfigL rawLocals <- getLocalPackageViews (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOptsWith rawLocals needTargets boptsCli -- Extend extra-deps to encompass targets requested on the command line @@ -173,9 +174,17 @@ , flip Map.mapWithKey (mbpPackages mbp) $ \n mpi -> let configOpts = getGhcOptions bconfig boptsCli n False False in PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi ++ configOpts) (mpiGitSHA1 mpi) - ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) + ] + -- This conditional was introduced in order to fix "stack + -- list-dependencies --license" (#2871) for wired-in-packages. + -- Normally, they are omitted as they shouldn't be considered + -- as packages available for installation. + sourceMap' = + if omitWiredIn + then sourceMap `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) + else sourceMap - return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap) + return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap') -- | All flags for a local package getLocalFlags @@ -198,13 +207,16 @@ , if boptsLibProfile bopts || boptsExeProfile bopts then ["-auto-all","-caf-all"] else [] + , if not $ boptsLibStrip bopts || boptsExeStrip bopts + then ["-g"] + else [] , if includeExtraOptions then boptsCLIGhcOptions boptsCli else [] ] where bopts = configBuild config - config = bcConfig bconfig + config = view configL bconfig includeExtraOptions = case configApplyGhcOptions config of AGOTargets -> isTarget @@ -233,14 +245,14 @@ -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) parseTargetsFromBuildOptsWith rawLocals needTargets boptscli = do $logDebug "Parsing the targets" - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL mbp0 <- case bcResolver bconfig of ResolverCompiler _ -> do -- We ignore the resolver version, as it might be -- GhcMajorVersion, and we want the exact version -- we're using. - version <- asks (envConfigCompilerVersion . getEnvConfig) + version <- view actualCompilerVersionL return MiniBuildPlan { mbpCompilerVersion = version , mbpPackages = Map.empty @@ -358,7 +370,7 @@ loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do let mtarget = Map.lookup name targets config <- getPackageConfig boptsCli name (isJust mtarget) True - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL let pkg = resolvePackage config gpkg (exes, tests, benches) = @@ -447,7 +459,7 @@ -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL -- Check if flags specified in stack.yaml and the command line are -- used, see https://github.com/commercialhaskell/stack/issues/617 @@ -499,7 +511,7 @@ case errs of [] -> return $ Map.unions $ extraDeps1 : unknowns' _ -> do - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL throwM $ UnknownTargets (Set.fromList errs) Map.empty -- TODO check the cliExtraDeps for presence in index @@ -620,7 +632,7 @@ return FileCacheInfo { fciModTime = modTime' , fciSize = size - , fciHash = toBytes (digest :: Digest SHA256) + , fciHash = Mem.convert (digest :: Digest SHA256) } checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m () @@ -636,15 +648,15 @@ getDefaultPackageConfig :: (MonadIO m, MonadReader env m, HasEnvConfig env) => m PackageConfig getDefaultPackageConfig = do - econfig <- asks getEnvConfig - bconfig <- asks getBuildConfig + platform <- view platformL + compilerVersion <- view actualCompilerVersionL return PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = M.empty , packageConfigGhcOptions = [] - , packageConfigCompilerVersion = envConfigCompilerVersion econfig - , packageConfigPlatform = configPlatform $ getConfig bconfig + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = platform } -- | Get 'PackageConfig' for package given its name. @@ -655,13 +667,14 @@ -> Bool -> m PackageConfig getPackageConfig boptsCli name isTarget isLocal = do - econfig <- asks getEnvConfig - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL + platform <- view platformL + compilerVersion <- view actualCompilerVersionL return PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = getLocalFlags bconfig boptsCli name , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name isTarget isLocal - , packageConfigCompilerVersion = envConfigCompilerVersion econfig - , packageConfigPlatform = configPlatform $ getConfig bconfig + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = platform } diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -220,7 +220,7 @@ (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) (Map.toList locals) in case filter (isCompNamed cname . snd) allPairs of - [] -> Left $ "Could not find a component named " `T.append` cname + [] -> Left $ cname `T.append` " doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets" [(name, comp)] -> Right (name, (ri, STLocalComps $ Set.singleton comp)) matches -> Left $ T.concat diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -32,6 +32,7 @@ , showItems , showPackageFlags , parseCustomMiniBuildPlan + , loadBuildPlan ) where import Control.Applicative @@ -40,12 +41,13 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.State.Strict (State, execState, get, modify, put) -import qualified Crypto.Hash.SHA256 as SHA256 +import Crypto.Hash (hashWith, SHA256(..)) import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings) import Data.Store.VersionTagged +import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as S8 @@ -207,8 +209,8 @@ resolveBuildPlan mbp isShadowed packages | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs) | otherwise = do - bconfig <- asks getBuildConfig - caches <- getPackageCaches + bconfig <- view buildConfigL + (caches, _gitShaCaches) <- getPackageCaches let maxVer = Map.fromListWith max $ map toTuple $ @@ -280,29 +282,24 @@ -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) addDeps allowMissing compilerVersion toCalc = do menv <- getMinimalEnvOverride - platform <- asks $ configPlatform . getConfig + platform <- view platformL (resolvedMap, missingIdents) <- if allowMissing then do (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing shaMap Set.empty + resolvePackagesAllowMissing menv Nothing shaMap Set.empty assert (Set.null missingNames) $ return (m, missingIdents) else do - m <- resolvePackages menv shaMap Set.empty + m <- resolvePackages menv Nothing shaMap Set.empty return (m, Set.empty) - let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap) - $ \(ident, rp) -> + let byIndex = Map.fromListWith (++) $ flip map resolvedMap + $ \rp -> let (cache, ghcOptions, sha) = - case Map.lookup (packageIdentifierName ident) toCalc of + case Map.lookup (packageIdentifierName (rpIdent rp)) toCalc of Nothing -> (Map.empty, [], Nothing) Just (_, x, y, z) -> (x, y, z) - in (indexName $ rpIndex rp, - [( ident - , rpCache rp - , sha - , (cache, ghcOptions, sha) - )]) + in (indexName $ rpIndex rp, [(rp, (cache, ghcOptions, sha))]) res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs $ \ident (flags, ghcOptions, mgitSha) cabalBS -> do (_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS @@ -490,7 +487,7 @@ -- if available, otherwise downloading from Github. loadBuildPlan :: (StackMiniM env m, HasConfig env) => SnapName -> m BuildPlan loadBuildPlan name = do - stackage <- asks getStackRoot + stackage <- view stackRootL file' <- parseRelFile $ T.unpack file let fp = buildPlanDir stackage file' $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) @@ -513,7 +510,7 @@ buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text buildBuildPlanUrl name file = do - urls <- asks (configUrls . getConfig) + urls <- view $ configL.to configUrls return $ case name of LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file @@ -729,7 +726,7 @@ -> SnapName -> m BuildPlanCheck checkSnapBuildPlan gpds flags snap = do - platform <- asks (configPlatform . getConfig) + platform <- view platformL mbp <- loadMiniBuildPlan snap let @@ -1064,9 +1061,9 @@ , mbpPackages = mempty } getCustomPlanDir = do - root <- asks $ configStackRoot . getConfig + root <- view stackRootL return $ root $(mkRelDir "custom-plan") - doHash = SnapshotHash . B64URL.encode . SHA256.hash + doHash = SnapshotHash . B64URL.encode . Mem.convert . hashWith SHA256 applyCustomSnapshot :: (StackMiniM env m, HasConfig env) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- 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 #-} @@ -38,6 +41,8 @@ ,getInContainer ,getInNixShell ,defaultConfigYaml + ,getProjectConfig + ,LocalConfigStatus(..) ) where import qualified Codec.Archive.Tar as Tar @@ -51,9 +56,10 @@ import Control.Monad.Extra (firstJustM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc) -import Control.Monad.Reader (ask, asks, runReaderT) -import qualified Crypto.Hash.SHA256 as SHA256 +import Control.Monad.Reader (ask, runReaderT) +import Crypto.Hash (hashWith, SHA256(..)) import Data.Aeson.Extended +import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Lazy as L @@ -70,6 +76,7 @@ import qualified Distribution.Text import Distribution.Version (simplifyVersionRange) import GHC.Conc (getNumProcessors) +import Lens.Micro (lens) import Network.HTTP.Client (parseUrlThrow) import Network.HTTP.Download (download) import Network.HTTP.Simple (httpJSON, getResponseBody) @@ -92,6 +99,7 @@ import Stack.Types.Docker import Stack.Types.Internal import Stack.Types.Nix +import Stack.Types.PackageIndex (HttpType (HTHackageSecurity), HackageSecurity (..)) import Stack.Types.Resolver import Stack.Types.StackT import Stack.Types.Urls @@ -154,7 +162,7 @@ :: (StackMiniM env m, HasConfig env) => m (Path Abs File) getStackYaml = do - config <- asks getConfig + config <- view configL case configMaybeProject config of Just (_project, stackYaml) -> return stackYaml Nothing -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir config) @@ -183,7 +191,7 @@ case ar of ARResolver r -> assert False $ return r ARGlobal -> do - config <- asks getConfig + config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config let fp = implicitGlobalDir stackDotYaml WithJSONWarnings (ProjectAndConfigMonoid project _) _warnings <- @@ -213,16 +221,38 @@ 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 @@ -237,7 +267,21 @@ { indexName = IndexName "Hackage" , indexLocation = ILGitHttp "https://github.com/commercialhaskell/all-cabal-hashes.git" - "https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz" + "https://s3.amazonaws.com/hackage.fpcomplete.com/" + (HTHackageSecurity HackageSecurity + { hsKeyIds = + [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833" + , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201" + , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" + , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d" + , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9" + , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + ] + , hsKeyThreshold = 3 + }) , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" , indexGpgVerify = False , indexRequireHashes = False @@ -372,21 +416,21 @@ _ -> return defaultBase -- | An environment with a subset of BuildConfig used for setup. -data MiniConfig = MiniConfig GHCVariant Config +data MiniConfig = MiniConfig + { mcGHCVariant :: !GHCVariant + , mcConfig :: !Config + } instance HasConfig MiniConfig where - getConfig (MiniConfig _ c) = c -instance HasStackRoot MiniConfig + configL = lens mcConfig (\x y -> x { mcConfig = y }) instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where - getGHCVariant (MiniConfig v _) = v + ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y }) -- | Load the 'MiniConfig'. -loadMiniConfig - :: MonadIO m - => Config -> m MiniConfig -loadMiniConfig config = do +loadMiniConfig :: Config -> MiniConfig +loadMiniConfig config = let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config) - return (MiniConfig ghcVariant config) + in MiniConfig ghcVariant config -- Load the configuration, using environment variables, and defaults as -- necessary. @@ -396,24 +440,36 @@ -- ^ 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))) @@ -427,7 +483,11 @@ 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, @@ -438,7 +498,7 @@ -- ^ 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 = @@ -447,20 +507,22 @@ -- | 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 - 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 @@ -472,7 +534,7 @@ if exists then do ProjectAndConfigMonoid project _ <- loadConfigYaml dest - when (getTerminal env) $ + when (view terminalL env) $ case mresolver of Nothing -> $logDebug ("Using resolver: " <> resolverName (projectResolver project) <> @@ -489,26 +551,9 @@ " 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" @@ -546,31 +591,58 @@ { bcConfig = config , bcResolver = loadedResolver , bcWantedMiniBuildPlan = mbp + , bcGHCVariant = view ghcVariantL miniConfig , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project - , bcImplicitGlobal = isNothing mproject - , bcGHCVariant = getGHCVariant miniConfig + , 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 ( getLocalPackages :: (StackMiniM env m, HasEnvConfig env) => m (Map.Map (Path Abs Dir) TreatLikeExtraDep) getLocalPackages = do - cacheRef <- asks (envConfigPackagesRef . getEnvConfig) + cacheRef <- view $ envConfigL.to envConfigPackagesRef mcached <- liftIO $ readIORef cacheRef case mcached of Just cached -> return cached Nothing -> do menv <- getMinimalEnvOverride - bconfig <- asks getBuildConfig + root <- view projectRootL + entries <- view $ buildConfigL.to bcPackageEntries liftM (Map.fromList . concat) $ mapM - (resolvePackageEntry menv (bcRoot bconfig)) - (bcPackageEntries bconfig) + (resolvePackageEntry menv root) + entries -- | Resolve a PackageEntry into a list of paths, downloading and cloning as -- necessary. @@ -618,19 +690,19 @@ -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do - workDir <- getWorkDir + workDir <- view workDirL let nameBeforeHashing = case remotePackageType of RPTHttp{} -> url RPTGit commit -> T.unwords [url, commit] RPTHg commit -> T.unwords [url, commit, "hg"] -- TODO: dedupe with code for snapshot hash? - name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing + name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing root = projRoot workDir $(mkRelDir "downloaded") - fileExtension = case remotePackageType of + fileExtension' = case remotePackageType of RPTHttp -> ".http-archive" _ -> ".unused" - fileRel <- parseRelFile $ name ++ fileExtension + fileRel <- parseRelFile $ name ++ fileExtension' dirRel <- parseRelDir name dirRelTmp <- parseRelDir $ name ++ ".tmp" let file = root fileRel @@ -818,7 +890,7 @@ $ fromMaybe userConfigPath mstackConfig : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath) --- | Load and parse YAML from the given conig file. Throws +-- | Load and parse YAML from the given config file. Throws -- 'ParseConfigFileException' when there's a decoding error. loadConfigYaml :: (FromJSON (WithJSONWarnings a), MonadIO m, MonadLogger m) @@ -843,19 +915,19 @@ -- | 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 @@ -865,29 +937,39 @@ 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. @@ -923,6 +1005,23 @@ ensureDir (parent path) 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/Config/Build.hs b/src/Stack/Config/Build.hs --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -15,6 +15,12 @@ , boptsExeProfile = fromFirst (boptsExeProfile defaultBuildOpts) buildMonoidExeProfile + , boptsLibStrip = fromFirst + (boptsLibStrip defaultBuildOpts) + buildMonoidLibStrip + , boptsExeStrip = fromFirst + (boptsExeStrip defaultBuildOpts) + buildMonoidExeStrip , boptsHaddock = fromFirst (boptsHaddock defaultBuildOpts) buildMonoidHaddock diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -18,7 +18,6 @@ import Control.Monad.Catch (throwM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap import Data.Monoid @@ -28,9 +27,11 @@ import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path +import Path.IO import Prelude -- Silence redundant import warnings import Stack.BuildPlan -import Stack.Config (makeConcreteResolver, getStackYaml) +import Stack.Config (makeConcreteResolver, getProjectConfig, getImplicitGlobalProjectDir, LocalConfigStatus(..)) +import Stack.Constants import Stack.Types.Config import Stack.Types.Resolver @@ -55,14 +56,21 @@ cfgCmdSet :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => ConfigCmdSet -> m () -cfgCmdSet cmd = do + => GlobalOpts -> ConfigCmdSet -> m () +cfgCmdSet go cmd = do + conf <- view configL configFilePath <- liftM toFilePath (case configCmdSetScope cmd of - CommandScopeProject -> getStackYaml - CommandScopeGlobal -> asks (configUserConfigPath . getConfig)) + CommandScopeProject -> do + mstackYamlOption <- forM (globalStackYaml go) resolveFile' + mstackYaml <- getProjectConfig mstackYamlOption + case mstackYaml of + 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) <- liftIO (Yaml.decodeFileEither configFilePath) >>= either throwM return diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -31,7 +31,7 @@ ,implicitGlobalProjectDir ,hpcRelativeDir ,hpcDirFromDir - ,objectInterfaceDir + ,objectInterfaceDirL ,templatesDir ,defaultUserConfigPathDeprecated ,defaultUserConfigPath @@ -48,6 +48,7 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Text (Text) +import Lens.Micro (Getting) import Path as FL import Prelude import Stack.Types.Compiler @@ -68,11 +69,11 @@ haskellPreprocessorExts = ["gc", "chs", "hsc", "x", "y", "ly", "cpphs"] -- | Output .o/.hi directory. -objectInterfaceDir :: (MonadReader env m, HasConfig env) - => BuildConfig -> m (Path Abs Dir) -objectInterfaceDir bconfig = do - bcwd <- bcWorkDir bconfig - return (bcwd $(mkRelDir "odir/")) +objectInterfaceDirL :: HasBuildConfig env => Getting r env (Path Abs Dir) +objectInterfaceDirL = to $ \env -> -- FIXME is this idomatic lens code? + let workDir = view workDirL env + root = view projectRootL env + in root workDir $(mkRelDir "odir/") -- | The filename used for dirtiness check of source files. buildCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) @@ -141,11 +142,10 @@ liftM (fp ) distRelativeDir -- | Package's working directory. -workDirFromDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) +workDirFromDir :: (MonadReader env m, HasEnvConfig env) => Path Abs Dir -> m (Path Abs Dir) -workDirFromDir fp = - liftM (fp ) getWorkDir +workDirFromDir fp = view $ workDirL.to (fp ) -- | Directory for project templates. templatesDir :: Config -> Path Abs Dir @@ -155,9 +155,9 @@ distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) distRelativeDir = do - cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) + cabalPkgVer <- view cabalVersionL platform <- platformGhcRelDir - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.to whichCompiler -- Cabal version, suffixed with "_ghcjs" if we're using GHCJS. envDir <- parseRelDir $ @@ -165,7 +165,7 @@ packageIdentifierString $ PackageIdentifier cabalPackageName cabalPkgVer platformAndCabal <- useShaPathOnWindows (platform envDir) - workDir <- getWorkDir + workDir <- view workDirL return $ workDir $(mkRelDir "dist") @@ -176,7 +176,7 @@ => Path Abs Dir -- ^ Project root -> m (Path Abs Dir) -- ^ Docker sandbox projectDockerSandboxDir projectRoot = do - workDir <- getWorkDir + workDir <- view workDirL return $ projectRoot workDir $(mkRelDir "docker/") -- | Image staging dir from project root. @@ -185,7 +185,7 @@ -> Int -- ^ Index of image -> m (Path Abs Dir) -- ^ Docker sandbox imageStagingDir projectRoot imageIdx = do - workDir <- getWorkDir + workDir <- view workDirL idxRelDir <- parseRelDir (show imageIdx) return $ projectRoot workDir $(mkRelDir "image") idxRelDir diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -21,7 +21,6 @@ import Control.Monad (liftM, when, unless, void, (<=<)) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8 import Data.Foldable (forM_, asum, toList) @@ -112,7 +111,7 @@ generateHpcReport :: (StackM env m, HasEnvConfig env) => Path Abs Dir -> Package -> [Text] -> m () generateHpcReport pkgDir package tests = do - compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) + compilerVersion <- view actualCompilerVersionL -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See -- https://github.com/commercialhaskell/stack/issues/785 let pkgName = packageNameText (packageName package) @@ -439,7 +438,7 @@ case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of Just result -> return $ Right result Nothing -> notFoundErr - cabalVer <- asks (envConfigCabalVersion . getEnvConfig) + cabalVer <- view cabalVersionL if cabalVer < $(mkVersion "1.24") then do path <- liftM (inplaceDir ) $ parseRelFile (pkgIdStr ++ "-inplace.conf") diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -27,10 +27,10 @@ import Control.Monad.Catch (MonadThrow,throwM,MonadCatch) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) -import Control.Monad.Reader (MonadReader,asks,runReaderT) +import Control.Monad.Reader (MonadReader,runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Writer (execWriter,runWriter,tell) -import qualified "cryptohash" Crypto.Hash as Hash +import qualified Crypto.Hash as Hash (Digest, MD5, hash) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS @@ -106,7 +106,7 @@ execWithOptionalContainer mprojectRoot getCmdArgs where getCmdArgs docker envOverride imageInfo isRemoteDocker = do - config <- asks getConfig + config <- view configL deUser <- if fromMaybe (not isRemoteDocker) (dockerSetUser docker) then liftIO $ do @@ -206,9 +206,9 @@ -> Maybe (m ()) -> m () execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease = - do config <- asks getConfig + do config <- view configL inContainer <- getInContainer - isReExec <- asks getReExec + isReExec <- view reExecL if | inContainer && not isReExec && (isJust mbefore || isJust mafter) -> throwM OnlyOnHostException | inContainer -> @@ -249,7 +249,7 @@ mprojectRoot before after = - do config <- asks getConfig + do config <- view configL let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride docker @@ -259,7 +259,7 @@ <*> hIsTerminalDevice stdin <*> hIsTerminalDevice stderr <*> (parseAbsDir =<< getHomeDirectory) - isStdoutTerminal <- asks getTerminal + isStdoutTerminal <- view terminalL let dockerHost = lookup "DOCKER_HOST" env dockerCertPath = lookup "DOCKER_CERT_PATH" env bamboo = lookup "bamboo_buildKey" env @@ -285,7 +285,7 @@ sandboxDir <- projectDockerSandboxDir projectRoot let ImageConfig {..} = iiConfig imageEnvVars = map (break (== '=')) icEnv - platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image + platformVariant = show $ hashRepoName image stackRoot = configStackRoot config sandboxHomeDir = sandboxDir homeDirName isTerm = not (dockerDetach docker) && @@ -417,7 +417,7 @@ cleanup :: (StackM env m, HasConfig env) => CleanupOpts -> m () cleanup opts = - do config <- asks getConfig + do config <- view configL let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride docker @@ -670,7 +670,7 @@ -- | Pull latest version of configured Docker image from registry. pull :: (StackM env m, HasConfig env) => m () pull = - do config <- asks getConfig + do config <- view configL let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride docker diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Stack.Dot (dot ,listDependencies @@ -30,7 +31,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Traversable as T -import Distribution.License (License) +import Distribution.License (License(BSD3)) import Prelude -- Fix redundant import warnings import Stack.Build (withLoadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) @@ -115,26 +116,26 @@ => DotOpts -> m (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do - (locals,sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI + (_, _, locals, _, _, sourceMap) <- loadSourceMapFull False NeedTargets defaultBuildOptsCLI { boptsCLITargets = dotTargets dotOpts , boptsCLIFlags = dotFlags dotOpts } let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals)) menv <- getMinimalEnvOverride installedMap <- fmap snd . fst4 <$> getInstalled menv - (GetInstalledOpts False False) + (GetInstalledOpts False False False) sourceMap withLoadPackage menv (\loader -> do - let depLoader = - createDepLoader sourceMap - installedMap - (fmap4 (packageAllDeps &&& makePayload) loader) + let depLoader = createDepLoader sourceMap installedMap loadPackageDeps + loadPackageDeps name version flags ghcOptions + -- Skip packages that can't be loaded - see + -- https://github.com/commercialhaskell/stack/issues/2967 + | name `elem` [$(mkPackageName "rts"), $(mkPackageName "ghc")] = + return (Set.empty, DotPayload (Just version) (Just BSD3)) + | otherwise = fmap (packageAllDeps &&& makePayload) + (loader name version flags ghcOptions) liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) - where -- fmap a function over the result of a function with 3 arguments - fmap4 :: Functor f => (r -> r') -> (a -> b -> c -> d -> f r) -> a -> b -> c -> d -> f r' - fmap4 f g a b c d = f <$> g a b c d - - fst4 :: (a,b,c,d) -> a + where fst4 :: (a,b,c,d) -> a fst4 (x,_,_,_) = x makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) @@ -275,7 +276,7 @@ -- | Print an edge between the two package names printEdge :: MonadIO m => PackageName -> PackageName -> m () -printEdge from to = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to, ";"]) +printEdge from to' = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to', ";"]) -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -39,10 +39,10 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (ask, asks, runReaderT) +import Control.Monad.Reader (ask, runReaderT) import Control.Monad.Trans.Control import Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase) -import "cryptohash" Crypto.Hash (SHA512 (..)) +import Crypto.Hash (SHA256 (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -53,6 +53,7 @@ import qualified Data.Git.Ref as Git import qualified Data.Git.Storage as Git import qualified Data.Git.Storage.Object as Git +import qualified Data.HashMap.Strict as HashMap import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -131,7 +132,7 @@ -> Set PackageIdentifier -> m () fetchPackages menv idents' = do - resolved <- resolvePackages menv idents Set.empty + resolved <- resolvePackages menv Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved assert (Map.null alreadyUnpacked) (return ()) nowUnpacked <- fetchPackages' Nothing toFetch @@ -144,15 +145,16 @@ -- | Intended to work for the command line command. unpackPackages :: (StackMiniM env m, HasConfig env) => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers -> m () -unpackPackages menv dest input = do +unpackPackages menv mMiniBuildPlan dest input = do dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages menv + resolved <- resolvePackages menv mMiniBuildPlan (Map.fromList $ map (, Nothing) idents) (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved @@ -185,24 +187,28 @@ -> Map PackageIdentifier (Maybe GitSHA1) -> m (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents menv unpackDir mdistDir idents = do - resolved <- resolvePackages menv idents Set.empty + resolved <- resolvePackages menv Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved nowUnpacked <- fetchPackages' mdistDir toFetch return $ alreadyUnpacked <> nowUnpacked data ResolvedPackage = ResolvedPackage - { rpCache :: !PackageCache + { rpIdent :: !PackageIdentifier + , rpCache :: !PackageCache , rpIndex :: !PackageIndex , rpGitSHA1 :: !(Maybe GitSHA1) + , rpMissingGitSHA :: !Bool } + deriving Show -- | Resolve a set of package names and identifiers into @FetchPackage@ values. resolvePackages :: (StackMiniM env m, HasConfig env) => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName - -> m (Map PackageIdentifier ResolvedPackage) -resolvePackages menv idents0 names0 = do + -> m [ResolvedPackage] +resolvePackages menv mMiniBuildPlan idents0 names0 = do eres <- go case eres of Left _ -> do @@ -210,7 +216,7 @@ go >>= either throwM return Right x -> return x where - go = r <$> resolvePackagesAllowMissing idents0 names0 + go = r <$> resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 r (missingNames, missingIdents, idents) | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" @@ -218,36 +224,105 @@ resolvePackagesAllowMissing :: (StackMiniM env m, HasConfig env) - => Map PackageIdentifier (Maybe GitSHA1) + => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName - -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage) -resolvePackagesAllowMissing idents0 names0 = do - caches <- getPackageCaches - let versions = Map.fromListWith max $ map toTuple $ Map.keys caches - (missingNames, idents1) = partitionEithers $ map - (\name -> maybe (Left name ) (Right . PackageIdentifier name) - (Map.lookup name versions)) - (Set.toList names0) - (missingIdents, resolved) = partitionEithers $ map (goIdent caches) - $ Map.toList - $ idents0 <> Map.fromList (map (, Nothing) idents1) - return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved) + -> m (Set PackageName, Set PackageIdentifier, [ResolvedPackage]) +resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 = do + res@(_, _, resolved) <- inner + if any rpMissingGitSHA resolved + then do + $logInfo "Missing some cabal revision files, updating indices" + updateAllIndices menv + res'@(_, _, resolved') <- inner + + -- Print an error message if any SHAs are still missing. + F.forM_ (filter rpMissingGitSHA resolved') + $ \rp -> F.forM_ (rpGitSHA1 rp) $ \(GitSHA1 sha) -> + $logWarn $ mconcat + [ "Did not find .cabal file for " + , T.pack $ packageIdentifierString $ rpIdent rp + , " with SHA of " + , decodeUtf8 sha + , " in tarball-based cache" + ] + + return res' + else return res where - goIdent caches (ident, mgitsha) = + inner = do + (caches, shaCaches) <- getPackageCaches + + let versions = Map.fromListWith max $ map toTuple $ Map.keys caches + + getNamed :: PackageName -> Maybe (PackageIdentifier, Maybe GitSHA1) + getNamed = + case mMiniBuildPlan of + Nothing -> getNamedFromIndex + Just mbp -> getNamedFromBuildPlan mbp + + getNamedFromBuildPlan mbp name = do + mpi <- Map.lookup name $ mbpPackages mbp + Just (PackageIdentifier name (mpiVersion mpi), mpiGitSHA1 mpi) + getNamedFromIndex name = fmap + (\ver -> (PackageIdentifier name ver, Nothing)) + (Map.lookup name versions) + + (missingNames, idents1) = partitionEithers $ map + (\name -> maybe (Left name) Right (getNamed name)) + (Set.toList names0) + let (missingIdents, resolved) = partitionEithers $ map (goIdent caches shaCaches) + $ Map.toList + $ idents0 <> Map.fromList idents1 + return (Set.fromList missingNames, Set.fromList missingIdents, resolved) + + goIdent caches shaCaches (ident, mgitsha) = case Map.lookup ident caches of Nothing -> Left ident - Just (index, cache) -> Right (ident, ResolvedPackage - { rpCache = cache - , rpIndex = index - , rpGitSHA1 = mgitsha - }) + Just (index, cache) -> + let (index', cache', mgitsha', missingGitSHA) = + case mgitsha of + Nothing -> (index, cache, mgitsha, False) + Just gitsha -> + case HashMap.lookup gitsha shaCaches of + Just (index'', offsetSize) -> + ( index'' + , cache { pcOffsetSize = offsetSize } + -- we already got the info + -- about this SHA, don't do + -- any lookups later + , Nothing + , False -- not missing, we found the Git SHA + ) + Nothing -> (index, cache, mgitsha, + case simplifyIndexLocation (indexLocation index) of + -- No surprise that there's + -- nothing in the cache about + -- the SHA, since this package + -- comes from a Git + -- repo. We'll look it up + -- later when we've opened up + -- the Git repo itself for + -- reading. + SILGit _ -> False + -- Index using HTTP, so we're missing the Git SHA + SILHttp _ _ -> True) + in Right ResolvedPackage + { rpIdent = ident + , rpCache = cache' + , rpIndex = index' + , rpGitSHA1 = mgitsha' + , rpMissingGitSHA = missingGitSHA + } + data ToFetch = ToFetch { tfTarball :: !(Path Abs File) , tfDestDir :: !(Maybe (Path Abs Dir)) , tfUrl :: !T.Text , tfSize :: !(Maybe Word64) - , tfSHA512 :: !(Maybe ByteString) + , tfSHA256 :: !(Maybe ByteString) , tfCabal :: !ByteString -- ^ Contents of the .cabal file } @@ -261,7 +336,7 @@ withCabalFiles :: (StackMiniM env m, HasConfig env) => IndexName - -> [(PackageIdentifier, PackageCache, Maybe GitSHA1, a)] + -> [(ResolvedPackage, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) -> m [b] withCabalFiles name pkgs f = do @@ -280,7 +355,7 @@ (liftIO . Git.closeRepo) (inner . Just) where - goPkg h (Just git) (ident, pc, Just (GitSHA1 sha), tf) = do + goPkg h (Just git) (rp@(ResolvedPackage ident _pc _index (Just (GitSHA1 sha)) _missing), tf) = do let ref = Git.fromHex sha mobj <- liftIO $ tryIO $ Git.getObject git ref True case mobj of @@ -290,15 +365,19 @@ $logWarn $ mconcat [ "Did not find .cabal file for " , T.pack $ packageIdentifierString ident - , " with Git SHA of " + , " with SHA of " , decodeUtf8 sha + , " in the Git repository" ] $logDebug (T.pack (show e)) - goPkg h Nothing (ident, pc, Nothing, tf) - goPkg h _mgit (ident, pc, _mgitsha, tf) = liftIO $ do - hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc - cabalBS <- S.hGet h $ fromIntegral $ pcSize pc - f ident tf cabalBS + goPkg h Nothing (rp { rpGitSHA1 = Nothing }, tf) + goPkg h _mgit (ResolvedPackage ident pc _index _mgitsha _missing, tf) = do + -- Did not find warning for tarballs is handled above + let OffsetSize offset size = pcOffsetSize pc + liftIO $ do + hSeek h AbsoluteSeek $ fromIntegral offset + cabalBS <- S.hGet h $ fromIntegral size + f ident tf cabalBS -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. @@ -325,7 +404,7 @@ let doLookup :: PackageIdentifier -> IO ByteString doLookup ident = do - caches <- loadCaches + (caches, _gitSHACaches) <- loadCaches eres <- unlift $ lookupPackageIdentifierExact ident env caches case eres of Just bs -> return bs @@ -370,7 +449,14 @@ Nothing -> return Nothing Just (index, cache) -> do [bs] <- flip runReaderT env - $ withCabalFiles (indexName index) [(ident, cache, Nothing, ())] + $ withCabalFiles (indexName index) + [(ResolvedPackage + { rpIdent = ident + , rpCache = cache + , rpIndex = index + , rpGitSHA1 = Nothing + , rpMissingGitSHA = False + }, ())] $ \_ _ bs -> return bs return $ Just bs @@ -407,17 +493,18 @@ -- | Figure out where to fetch from. getToFetch :: (StackMiniM env m, HasConfig env) => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack - -> Map PackageIdentifier ResolvedPackage + -> [ResolvedPackage] -> m ToFetchResult getToFetch mdest resolvedAll = do - (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked $ Map.toList resolvedAll + (toFetch0, unpacked) <- liftM partitionEithers $ mapM checkUnpacked resolvedAll toFetch1 <- mapM goIndex $ Map.toList $ Map.fromListWith (++) toFetch0 return ToFetchResult { tfrToFetch = Map.unions toFetch1 , tfrAlreadyUnpacked = Map.fromList unpacked } where - checkUnpacked (ident, resolved) = do + checkUnpacked resolved = do + let ident = rpIdent resolved dirRel <- parseRelDir $ packageIdentifierString ident let mdestDir = ( dirRel) <$> mdest mexists <- @@ -433,14 +520,14 @@ d = pcDownload $ rpCache resolved targz = T.pack $ packageIdentifierString ident ++ ".tar.gz" tarball <- configPackageTarball (indexName index) ident - return $ Left (indexName index, [(ident, rpCache resolved, rpGitSHA1 resolved, ToFetch + return $ Left (indexName index, [(resolved, ToFetch { tfTarball = tarball , tfDestDir = mdestDir - , tfUrl = case d of - Just d' -> decodeUtf8 $ pdUrl d' - Nothing -> indexDownloadPrefix index <> targz + , tfUrl = case fmap pdUrl d of + Just url | not (S.null url) -> decodeUtf8 url + _ -> indexDownloadPrefix index <> targz , tfSize = fmap pdSize d - , tfSHA512 = fmap pdSHA512 d + , tfSHA256 = fmap pdSHA256 d , tfCabal = S.empty -- filled in by goIndex })]) @@ -468,7 +555,7 @@ -> Map PackageIdentifier ToFetch -> m (Map PackageIdentifier (Path Abs Dir)) fetchPackages' mdistDir toFetchAll = do - connCount <- asks $ configConnectionCount . getConfig + connCount <- view $ configL.to configConnectionCount outputVar <- liftIO $ newTVarIO Map.empty runInBase <- liftBaseWith $ \run -> return (void . run) @@ -488,10 +575,10 @@ req <- parseUrlThrow $ T.unpack $ tfUrl toFetch let destpath = tfTarball toFetch - let toHashCheck bs = HashCheck SHA512 (CheckHexDigestByteString bs) + let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs) let downloadReq = DownloadRequest { drRequest = req - , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch) + , drHashChecks = map toHashCheck $ maybeToList (tfSHA256 toFetch) , drLengthCheck = fromIntegral <$> tfSize toFetch , drRetryPolicy = drRetryPolicyDefault } diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -27,7 +27,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import Control.Monad.State.Strict (State, execState, get, modify) import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 @@ -66,6 +65,7 @@ import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.Config +import Stack.Types.FlagName import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -80,6 +80,8 @@ data GhciOpts = GhciOpts { ghciTargets :: ![Text] , ghciArgs :: ![String] + , ghciGhcOptions :: ![Text] + , ghciFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) , ghciGhcCommand :: !(Maybe FilePath) , ghciNoLoadModules :: !Bool , ghciAdditionalPackages :: ![String] @@ -132,11 +134,14 @@ -- of those targets. ghci :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> m () ghci opts@GhciOpts{..} = do + let buildOptsCLI = defaultBuildOptsCLI + { boptsCLITargets = [] + , boptsCLIFlags = ghciFlags + } -- Load source map, without explicit targets, to collect all info. - (locals, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI - { boptsCLITargets = [] } + (locals, sourceMap) <- loadSourceMap AllowNoTargets buildOptsCLI -- Parse --main-is argument. - mainIsTargets <- parseMainIsTargets ghciMainIs + mainIsTargets <- parseMainIsTargets buildOptsCLI ghciMainIs -- Parse to either file targets or build targets etargets <- preprocessTargets ghciTargets (inputTargets, mfileTargets) <- case etargets of @@ -148,7 +153,7 @@ (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets return (targetMap, Just (fileInfo, extraFiles)) Right rawTargets -> do - (_,_,normalTargets) <- parseTargetsFromBuildOpts AllowNoTargets defaultBuildOptsCLI + (_,_,normalTargets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI { boptsCLITargets = rawTargets } return (normalTargets, Nothing) -- Make sure the targets are known. @@ -160,7 +165,7 @@ -- Build required dependencies and setup local packages. buildDepsAndInitialSteps opts (map (packageNameText . fst) localTargets) -- Load the list of modules _after_ building, to catch changes in unlisted dependencies (#1180) - pkgs <- getGhciPkgInfos sourceMap addPkgs (fmap fst mfileTargets) localTargets + pkgs <- getGhciPkgInfos buildOptsCLI sourceMap addPkgs (fmap fst mfileTargets) localTargets checkForIssues pkgs -- Finally, do the invocation of ghci runGhci opts localTargets mainIsTargets pkgs @@ -181,9 +186,9 @@ (False, _) -> return (Left fileTargets) _ -> return (Right normalTargets) -parseMainIsTargets :: (StackM r m, HasEnvConfig r) => Maybe Text -> m (Maybe (Map PackageName SimpleTarget)) -parseMainIsTargets mtarget = forM mtarget $ \target -> do - (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets defaultBuildOptsCLI +parseMainIsTargets :: (StackM r m, HasEnvConfig r) => BuildOptsCLI -> Maybe Text -> m (Maybe (Map PackageName SimpleTarget)) +parseMainIsTargets buildOptsCLI mtarget = forM mtarget $ \target -> do + (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI { boptsCLITargets = [target] } return targets @@ -241,7 +246,7 @@ checkTargets mp = do let filtered = M.filter (== STUnknown) mp unless (M.null filtered) $ do - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL throwM $ UnknownTargets (M.keysSet filtered) M.empty (bcStackYaml bconfig) getAllLocalTargets @@ -300,6 +305,8 @@ eres <- tryAny $ build (const (return ())) Nothing defaultBuildOptsCLI { boptsCLITargets = targets , boptsCLIInitialBuildSteps = True + , boptsCLIFlags = ghciFlags + , boptsCLIGhcOptions = ghciGhcOptions } case eres of Right () -> return () @@ -321,9 +328,8 @@ -> [GhciPkgInfo] -> m () runGhci GhciOpts{..} targets mainIsTargets pkgs = do - config <- asks getConfig - bconfig <- asks getBuildConfig - wc <- getWhichCompiler + config <- view configL + wc <- view $ actualCompilerVersionL.whichCompilerL let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts hidePkgOpt = if null pkgs || not ghciHidePackages then [] else ["-hide-all-packages"] oneWordOpts bio @@ -342,7 +348,7 @@ $logWarn ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> T.unwords (map T.pack (nubOrd omittedOpts))) - oiDir <- objectInterfaceDir bconfig + oiDir <- view objectInterfaceDirL let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ] @@ -353,11 +359,12 @@ menv <- liftIO $ configEnvOverride config defaultEnvSettings execSpawn menv (fromMaybe (compilerExeName wc) ghciGhcCommand) - ("--interactive" : - -- This initial "-i" resets the include directories to not - -- include CWD. - "-i" : - odir <> pkgopts <> ghciArgs <> extras) + (("--interactive" : ) $ + -- This initial "-i" resets the include directories to + -- not include CWD. If there aren't any packages, CWD + -- is included. + (if null pkgs then id else ("-i" : )) $ + odir <> pkgopts <> map T.unpack ghciGhcOptions <> ghciArgs <> extras) interrogateExeForRenderFunction = do menv <- liftIO $ configEnvOverride config defaultEnvSettings output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] @@ -371,7 +378,7 @@ else do checkForDuplicateModules pkgs renderFn <- interrogateExeForRenderFunction - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) @@ -520,28 +527,31 @@ getGhciPkgInfos :: (StackM r m, HasEnvConfig r) - => SourceMap + => BuildOptsCLI + -> SourceMap -> [PackageName] -> Maybe (Map PackageName (Set (Path Abs File))) -> [(PackageName, (Path Abs File, SimpleTarget))] -> m [GhciPkgInfo] -getGhciPkgInfos sourceMap addPkgs mfileTargets localTargets = do +getGhciPkgInfos buildOptsCLI sourceMap addPkgs mfileTargets localTargets = do menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False + , getInstalledSymbols = False } sourceMap let localLibs = [name | (name, (_, target)) <- localTargets, hasLocalComp isCLib target] forM localTargets $ \(name, (cabalfp, target)) -> - makeGhciPkgInfo sourceMap installedMap localLibs addPkgs mfileTargets name cabalfp target + makeGhciPkgInfo buildOptsCLI sourceMap installedMap localLibs addPkgs mfileTargets name cabalfp target -- | Make information necessary to load the given package in GHCi. makeGhciPkgInfo :: (StackM r m, HasEnvConfig r) - => SourceMap + => BuildOptsCLI + -> SourceMap -> InstalledMap -> [PackageName] -> [PackageName] @@ -550,18 +560,19 @@ -> Path Abs File -> SimpleTarget -> m GhciPkgInfo -makeGhciPkgInfo sourceMap installedMap locals addPkgs mfileTargets name cabalfp target = do - bopts <- asks (configBuild . getConfig) - econfig <- asks getEnvConfig - bconfig <- asks getBuildConfig +makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets name cabalfp target = do + bopts <- view buildOptsL + econfig <- view envConfigL + bconfig <- view buildConfigL + compilerVersion <- view actualCompilerVersionL let config = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True - , packageConfigFlags = getLocalFlags bconfig defaultBuildOptsCLI name - , packageConfigGhcOptions = getGhcOptions bconfig defaultBuildOptsCLI name True True - , packageConfigCompilerVersion = envConfigCompilerVersion econfig - , packageConfigPlatform = configPlatform (getConfig bconfig) + , packageConfigFlags = getLocalFlags bconfig buildOptsCLI name + , packageConfigGhcOptions = getGhcOptions bconfig buildOptsCLI name True True + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = view platformL econfig } (warnings,gpkgdesc) <- readPackageUnresolved cabalfp diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -10,10 +10,8 @@ import Control.Exception import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader import qualified Data.ByteString.Char8 as S8 import Data.List (find) -import qualified Data.Map.Strict as Map import Data.Monoid import qualified Data.Set as Set import Lens.Micro @@ -23,7 +21,6 @@ import Stack.Fetch import Stack.Runners import Stack.Types.Config -import Stack.Types.Internal import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT @@ -83,7 +80,7 @@ (catch (withBuildConfigAndLock (set - (globalOptsBuildOptsMonoid . buildOptsMonoidHaddock) + (globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL) (Just True) go) (\lk -> @@ -100,14 +97,27 @@ hoogleMinIdent = PackageIdentifier hooglePackageName hoogleMinVersion hooglePackageIdentifier <- - do (_,_,resolved) <- + do menv <- getMinimalEnvOverride + (_,_,resolved) <- resolvePackagesAllowMissing + menv + + -- FIXME this Nothing means "do not follow any + -- specific snapshot", which matches old + -- behavior. However, since introducing the + -- logic to pin a name to a package in a + -- snapshot, we may arguably want to ensure + -- that we're grabbing the version of Hoogle + -- present in the snapshot currently being + -- used. + Nothing + mempty (Set.fromList [hooglePackageName]) return (case find ((== hooglePackageName) . packageIdentifierName) - (Map.keys resolved) of + (map rpIdent resolved) of Just ident@(PackageIdentifier _ ver) | ver >= hoogleMinVersion -> Right ident _ -> Left hoogleMinIdent) @@ -122,7 +132,7 @@ ". Found acceptable " <> packageIdentifierText ident <> " in your index, installing it.") - config <- asks getConfig + config <- view configL menv <- liftIO $ configEnvOverride config envSettings liftIO (catch @@ -145,7 +155,7 @@ _ -> throwIO e)) runHoogle :: [String] -> StackT EnvConfig IO () runHoogle hoogleArgs = do - config <- asks getConfig + config <- view configL menv <- liftIO $ configEnvOverride config envSettings dbpath <- hoogleDatabasePath let databaseArg = ["--database=" ++ toFilePath dbpath] @@ -163,7 +173,7 @@ path <- hoogleDatabasePath liftIO (doesFileExist path) checkHoogleInPath = do - config <- asks getConfig + config <- view configL menv <- liftIO $ configEnvOverride config envSettings result <- tryProcessStdout Nothing menv "hoogle" ["--numeric-version"] case fmap (reads . S8.unpack) result of diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -49,5 +49,5 @@ toNameAndComponent (Map.toList (Map.map fst rawLocals))))) where - toNameAndComponent (pkgName,view) = - map (pkgName, ) (Set.toList (lpvComponents view)) + toNameAndComponent (pkgName,view') = + map (pkgName, ) (Set.toList (lpvComponents view')) diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -15,7 +15,6 @@ import Control.Monad import Control.Monad.Catch hiding (bracket) import Control.Monad.IO.Class -import Control.Monad.Reader import Data.Char (toLower) import qualified Data.Map.Strict as Map import Data.Maybe @@ -37,7 +36,7 @@ :: (StackM env m, HasEnvConfig env) => Maybe (Path Abs Dir) -> [Text] -> m () stageContainerImageArtifacts mProjectRoot imageNames = do - config <- asks getConfig + config <- view configL forM_ (zip [0 ..] @@ -60,7 +59,7 @@ :: (StackM env m, HasConfig env) => Maybe (Path Abs Dir) -> [Text] -> m () createContainerImageFromStage mProjectRoot imageNames = do - config <- asks getConfig + config <- view configL forM_ (zip [0 ..] @@ -105,12 +104,12 @@ :: (StackM env m, HasEnvConfig env) => ImageDockerOpts -> Path Abs Dir -> m () syncAddContentToDir opts dir = do - bconfig <- asks getBuildConfig + root <- view projectRootL let imgAdd = imgDockerAdd opts forM_ (Map.toList imgAdd) (\(source,destPath) -> - do sourcePath <- resolveDir (bcRoot bconfig) source + do sourcePath <- resolveDir root source let destFullPath = dir dropRoot destPath ensureDir destFullPath copyDirRecur sourcePath destFullPath) diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -8,36 +8,36 @@ , InitOpts (..) ) where -import Control.Exception (assert) -import Control.Exception.Safe (catchAny) +import Control.Exception (assert) +import Control.Exception.Safe (catchAny) import Control.Monad -import Control.Monad.Catch (throwM) +import Control.Monad.Catch (throwM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import qualified Data.Foldable as F -import Data.Function (on) -import qualified Data.HashMap.Strict as HM -import qualified Data.IntMap as IntMap -import Data.List ( intercalate, intersect - , maximumBy) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) -import qualified Data.Map as Map +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import Data.Function (on) +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap as IntMap +import Data.List (intercalate, intersect, + maximumBy) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe import Data.Monoid -import qualified Data.Text as T -import qualified Data.Yaml as Yaml +import qualified Data.Text as T +import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C -import qualified Distribution.Text as C -import qualified Distribution.Version as C +import qualified Distribution.Text as C +import qualified Distribution.Version as C import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO -import qualified Paths_stack as Meta +import qualified Paths_stack as Meta import Stack.BuildPlan import Stack.Config (getSnapshots, makeConcreteResolver) @@ -49,9 +49,9 @@ import Stack.Types.FlagName import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.StackT (StackM) +import Stack.Types.StackT (StackM) import Stack.Types.Version -import qualified System.FilePath as FP +import qualified System.FilePath as FP -- | Generate stack.yaml initProject @@ -105,7 +105,6 @@ \satisfy all dependencies. Some external packages have been \ \added as dependencies.\n" | otherwise = "" - makeUserMsg msgs = let msg = concat msgs in if msg /= "" then @@ -130,8 +129,8 @@ case stripDir currDir dir of Nothing | currDir == dir -> "." - | otherwise -> assert False $ toFilePath dir - Just rel -> toFilePath rel + | otherwise -> assert False $ toFilePathNoTrailingSep dir + Just rel -> toFilePathNoTrailingSep rel makeRel = fmap toFilePath . makeRelativeToCurrentDir @@ -469,7 +468,7 @@ -- the list of packages when there is conflict in dependencies among this -- set of packages. findOneIndependent packages flags = do - platform <- asks (configPlatform . getConfig) + platform <- view platformL (compiler, _) <- getResolverConstraints stackYaml resolver let getGpd pkg = snd (fromJust (Map.lookup pkg bundle)) getFlags pkg = fromJust (Map.lookup pkg flags) diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -22,7 +22,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader import Control.Monad.Trans.Writer.Strict import Data.Aeson import Data.Aeson.Types @@ -90,7 +89,7 @@ else do relDir <- parseRelDir (packageNameString project) liftM (pwd ) (return relDir) exists <- doesDirExist absDir - configTemplate <- asks (configDefaultTemplate . getConfig) + configTemplate <- view $ configL.to configDefaultTemplate let template = fromMaybe defaultTemplateName $ asum [ cliOptionTemplate , configTemplate ] @@ -134,7 +133,7 @@ :: forall env m. (StackM env m, HasConfig env) => TemplateName -> (TemplateFrom -> m ()) -> m Text loadTemplate name logIt = do - templateDir <- asks (templatesDir . getConfig) + templateDir <- view $ configL.to templatesDir case templatePath name of AbsPath absFile -> logIt LocalTemp >> loadLocalFile absFile UrlPath s -> do @@ -183,7 +182,7 @@ -> Text -> m (Map (Path Abs File) LB.ByteString) applyTemplate project template nonceParams dir templateText = do - config <- asks getConfig + config <- view configL currentYear <- do now <- liftIO getCurrentTime (year, _, _) <- return $ toGregorian . utctDay $ now @@ -265,7 +264,7 @@ => Path Abs Dir -> m () runTemplateInits dir = do menv <- getMinimalEnvOverride - config <- asks getConfig + config <- view configL case configScmInit config of Nothing -> return () Just Git -> diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -16,7 +16,6 @@ import Control.Monad hiding (mapM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (logDebug) -import Control.Monad.Reader (asks) import Data.Maybe import Data.Monoid import qualified Data.Text as T @@ -50,10 +49,10 @@ -> IO () -> m () reexecWithOptionalShell mprojectRoot getCompilerVersion inner = - do config <- asks getConfig + do config <- view configL inShell <- getInNixShell inContainer <- getInContainer - isReExec <- asks getReExec + isReExec <- view reExecL let getCmdArgs = do origArgs <- liftIO getArgs let args | inContainer = origArgs -- internal-re-exec version already passed @@ -74,7 +73,7 @@ -> m (String, [String]) -> m () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do - config <- asks getConfig + config <- view configL envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- fmap (escape *** map escape) getCmdArgs mshellFile <- diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -13,14 +13,14 @@ buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = - transform <$> trace <*> profile <*> options + transform <$> trace <*> profile <*> noStrip <*> options where hideBool = hide0 /= BuildCmdGlobalOpts hide = hideMods hideBool hideExceptGhci = hideMods (hide0 `notElem` [BuildCmdGlobalOpts, GhciCmdGlobalOpts]) - transform tracing profiling = + transform tracing profiling noStripping = enable where enable opts @@ -37,6 +37,11 @@ additionalArgs } } + | noStripping = + opts + { buildMonoidLibStrip = First (Just False) + , buildMonoidExeStrip = First (Just False) + } | otherwise = opts where @@ -75,13 +80,28 @@ \for all expressions and generate a backtrace on \ \exception" <> hideExceptGhci) + + noStrip = + flag + False + True + (long "no-strip" <> + help + "Disable DWARF debugging symbol stripping in libraries, \ + \executables, etc. for all expressions, producing \ + \larger executables but allowing the use of standard \ + \debuggers/profiling tools/other utilities that use \ + \debugging symbols." <> + hideExceptGhci) + options = - BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> haddock <*> - haddockOptsParser hideBool <*> openHaddocks <*> haddockDeps <*> - haddockInternal <*> copyBins <*> preFetch <*> keepGoing <*> - forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*> - benchOptsParser hideBool <*> reconfigure <*> - cabalVerbose <*> splitObjs + BuildOptsMonoid <$> libProfiling <*> exeProfiling <*> libStripping <*> + exeStripping <*> haddock <*> haddockOptsParser hideBool <*> + openHaddocks <*> haddockDeps <*> haddockInternal <*> copyBins <*> + preFetch <*> keepGoing <*> forceDirty <*> tests <*> + testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> + reconfigure <*> cabalVerbose <*> splitObjs + libProfiling = firstBoolFlags "library-profiling" @@ -91,6 +111,16 @@ firstBoolFlags "executable-profiling" "executable profiling for TARGETs and all its dependencies" + hide + libStripping = + firstBoolFlags + "library-stripping" + "library stripping for TARGETs and all its dependencies" + hide + exeStripping = + firstBoolFlags + "executable-stripping" + "executable stripping for TARGETs and all its dependencies" hide haddock = firstBoolFlags diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs --- a/src/Stack/Options/ConfigParser.hs +++ b/src/Stack/Options/ConfigParser.hs @@ -1,10 +1,12 @@ module Stack.Options.ConfigParser where import Data.Char +import Data.Either.Combinators import Data.Monoid.Extra import qualified Data.Set as Set import Options.Applicative import Options.Applicative.Builder.Extra +import Path import Stack.Constants import Stack.Options.BuildMonoidParser import Stack.Options.DockerParser @@ -46,7 +48,7 @@ "(Overrides any STACK_ROOT environment variable)") <> hide )) - <*> optionalFirst (relDirOption + <*> optionalFirst (option (eitherReader (mapLeft showWorkDirError . parseRelDir)) ( long "work-dir" <> metavar "WORK-DIR" <> help "Override work directory (default: .stack-work)" @@ -129,3 +131,6 @@ toDumpLogs (First (Just True)) = First (Just DumpAllLogs) toDumpLogs (First (Just False)) = First (Just DumpNoLogs) toDumpLogs (First Nothing) = First Nothing + showWorkDirError err = show err ++ + "\nNote that --work-dir must be a relative child directory, because work-dirs outside of the package are not supported by Cabal." ++ + "\nSee https://github.com/commercialhaskell/stack/issues/2954" diff --git a/src/Stack/Options/ExecParser.hs b/src/Stack/Options/ExecParser.hs --- a/src/Stack/Options/ExecParser.hs +++ b/src/Stack/Options/ExecParser.hs @@ -3,6 +3,7 @@ import Data.Monoid.Extra import Options.Applicative import Options.Applicative.Builder.Extra +import Options.Applicative.Args import Stack.Types.Config -- | Parser for exec command @@ -32,6 +33,7 @@ ExecOptsEmbellished <$> eoEnvSettingsParser <*> eoPackagesParser + <*> eoRtsOptionsParser where eoEnvSettingsParser :: Parser EnvSettings eoEnvSettingsParser = EnvSettings @@ -48,6 +50,12 @@ eoPackagesParser :: Parser [String] eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed")) + + eoRtsOptionsParser :: Parser [String] + eoRtsOptionsParser = concat <$> many (argsOption + ( long "rts-options" + <> help "Explicit RTS options to pass to application" + <> metavar "RTSFLAG")) eoPlainParser :: Parser ExecOptsExtra eoPlainParser = flag' ExecOptsPlain diff --git a/src/Stack/Options/GhciParser.hs b/src/Stack/Options/GhciParser.hs --- a/src/Stack/Options/GhciParser.hs +++ b/src/Stack/Options/GhciParser.hs @@ -1,13 +1,14 @@ module Stack.Options.GhciParser where -import Data.Monoid.Extra -import Data.Version (showVersion) -import Options.Applicative -import Options.Applicative.Args -import Options.Applicative.Builder.Extra -import Paths_stack as Meta -import Stack.Config (packagesParser) -import Stack.Ghci (GhciOpts (..)) +import Data.Monoid.Extra +import Data.Version (showVersion) +import Options.Applicative +import Options.Applicative.Args +import Options.Applicative.Builder.Extra +import Paths_stack as Meta +import Stack.Config (packagesParser) +import Stack.Ghci (GhciOpts (..)) +import Stack.Options.BuildParser (flagsParser) -- | Parser for GHCI options ghciOptsParser :: Parser GhciOpts @@ -23,6 +24,12 @@ <*> fmap concat (many (argsOption (long "ghci-options" <> metavar "OPTION" <> help "Additional options passed to GHCi"))) + <*> many + (textOption + (long "ghc-options" <> + metavar "OPTION" <> + help "Additional options passed to both GHC and GHCi")) + <*> flagsParser <*> optional (strOption (long "with-ghc" <> metavar "GHC" <> diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -61,7 +61,7 @@ , 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/Options/NixParser.hs b/src/Stack/Options/NixParser.hs --- a/src/Stack/Options/NixParser.hs +++ b/src/Stack/Options/NixParser.hs @@ -17,7 +17,7 @@ "use of a Nix-shell. Implies 'system-ghc: true'" hide <*> firstBoolFlags "nix-pure" - "use of a pure Nix-shell. Implies 'system-ghc: true'" + "use of a pure Nix-shell. Implies '--nix' and 'system-ghc: true'" hide <*> optionalFirst (textArgsOption @@ -51,6 +51,7 @@ where hide = hideMods hide0 overrideActivation m = - if m /= mempty then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) } - else m + if fromFirst False (nixMonoidPureShell m) + then m { nixMonoidEnable = (First . Just . fromFirst True) (nixMonoidEnable m) } + else m textArgsOption = fmap (map T.pack) . argsOption diff --git a/src/Stack/Options/ScriptParser.hs b/src/Stack/Options/ScriptParser.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Options/ScriptParser.hs @@ -0,0 +1,33 @@ +module Stack.Options.ScriptParser where + +import Data.Monoid ((<>)) +import Options.Applicative + +data ScriptOpts = ScriptOpts + { soPackages :: ![String] + , soFile :: !FilePath + , soArgs :: ![String] + , soCompile :: !ScriptExecute + } + deriving Show + +data ScriptExecute + = SEInterpret + | SECompile + | SEOptimize + deriving Show + +scriptOptsParser :: Parser ScriptOpts +scriptOptsParser = ScriptOpts + <$> many (strOption (long "package" <> help "Additional packages that must be installed")) + <*> strArgument (metavar "FILENAME") + <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")) + <*> (flag' SECompile + ( long "compile" + <> help "Compile the script without optimization and run the executable" + ) <|> + flag' SEOptimize + ( long "optimize" + <> help "Compile the script with optimization and run the executable" + ) <|> + pure SEInterpret) diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -244,6 +244,7 @@ (not . null . exposedModules) (library pkg) , packageSimpleType = buildType pkg == Just Simple + , packageSetupDeps = msetupDeps } where pkgFiles = GetPackageFiles $ @@ -271,7 +272,17 @@ return (componentModules, componentFiles, buildFiles <> dataFiles', warnings) pkgId = package pkg name = fromCabalPackageName (pkgName pkgId) - deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg) + deps = M.filterWithKey (const . (/= name)) (M.union + (packageDependencies pkg) + -- We include all custom-setup deps - if present - in the + -- package deps themselves. Stack always works with the + -- invariant that there will be a single installed package + -- relating to a package name, and this applies at the setup + -- dependency level as well. + (fromMaybe M.empty msetupDeps)) + msetupDeps = fmap + (M.fromList . map (depName &&& depRange) . setupDepends) + (setupBuildInfo pkg) -- | Generate GHC options for the package's components, and a list of -- options which apply generally to the package, not one specific @@ -287,7 +298,7 @@ -> Map NamedComponent (Set DotCabalPath) -> m (Map NamedComponent BuildInfoOpts) generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do - config <- asks getConfig + config <- view configL distDir <- distDirFromDir cabalDir let cabalMacros = autogenDir distDir $(mkRelFile "cabal_macros.h") exists <- doesFileExist cabalMacros @@ -409,7 +420,7 @@ | Just makeGenDir <- [fileGenDirFromComponentName biComponentName]]) ++ ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir)] toIncludeDir "." = Just biCabalDir - toIncludeDir x = fmap (biCabalDir ) (parseRelDir x) + toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir includeOpts = map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts) configExtraIncludeDirs = @@ -504,11 +515,11 @@ -- | Get all dependencies of the package (buildable targets only). packageDependencies :: PackageDescription -> Map PackageName VersionRange -packageDependencies = - M.fromListWith intersectVersionRanges . - concatMap (fmap (depName &&& depRange) . - targetBuildDepends) . - allBuildInfo' +packageDependencies pkg = + M.fromListWith intersectVersionRanges $ + map (depName &&& depRange) $ + concatMap targetBuildDepends (allBuildInfo' pkg) ++ + maybe [] setupDepends (setupBuildInfo pkg) -- | Get all build tool dependencies of the package (buildable targets only). packageToolDependencies :: PackageDescription -> Map Text VersionRange @@ -758,11 +769,7 @@ -- | Get the target's JS sources. targetJsSources :: BuildInfo -> [FilePath] -#if MIN_VERSION_Cabal(1, 22, 0) targetJsSources = jsSources -#else -targetJsSources = const [] -#endif -- | Get all dependencies of a package, including library, -- executables, tests, benchmarks. @@ -868,11 +875,7 @@ case (flavor, rcCompilerVersion rc) of (GHC, GhcVersion vghc) -> vghc `withinRange` range (GHC, GhcjsVersion _ vghc) -> vghc `withinRange` range -#if MIN_VERSION_Cabal(1, 22, 0) (GHCJS, GhcjsVersion vghcjs _) -> -#else - (OtherCompiler "ghcjs", GhcjsVersion vghcjs _) -> -#endif vghcjs `withinRange` range _ -> False @@ -1010,7 +1013,7 @@ thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do mresolved <- forgivingAbsence (resolveFile dir x) >>= rejectMissingFile when (isNothing mresolved) $ - $logWarn $ "Warning: qAddDepedency path listed in " <> T.pack dumpHIPath <> + $logWarn $ "Warning: addDependentFile path (Template Haskell) listed in " <> T.pack dumpHIPath <> " does not exist: " <> T.pack x return mresolved return (moduleDeps, thDepsResolved) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -19,6 +19,7 @@ , saveInstalledCache , addProfiling , addHaddock + , addSymbols , sinkMatching , pruneDeps ) where @@ -38,6 +39,7 @@ import qualified Data.Conduit.Text as CT import Data.Either (partitionEithers) import Data.IORef +import Data.List (isPrefixOf) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (catMaybes, listToMaybe) @@ -47,6 +49,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) +import qualified Distribution.System as OS import Path import Path.Extra (toFilePathNoTrailingSep) import Prelude -- Fix AMP warning @@ -168,14 +171,16 @@ sinkMatching :: Monad m => Bool -- ^ require profiling? -> Bool -- ^ require haddock? + -> Bool -- ^ require debugging symbols? -> Map PackageName Version -- ^ allowed versions - -> Consumer (DumpPackage Bool Bool) + -> Consumer (DumpPackage Bool Bool Bool) m - (Map PackageName (DumpPackage Bool Bool)) -sinkMatching reqProfiling reqHaddock allowed = do + (Map PackageName (DumpPackage Bool Bool Bool)) +sinkMatching reqProfiling reqHaddock reqSymbols allowed = do dps <- CL.filter (\dp -> isAllowed (dpPackageIdent dp) && (not reqProfiling || dpProfiling dp) && - (not reqHaddock || dpHaddock dp)) + (not reqHaddock || dpHaddock dp) && + (not reqSymbols || dpSymbols dp)) =$= CL.consume return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps id @@ -192,7 +197,7 @@ -- | Add profiling information to the stream of @DumpPackage@s addProfiling :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b) m (DumpPackage Bool b) + -> Conduit (DumpPackage a b c) m (DumpPackage Bool b c) addProfiling (InstalledCache ref) = CL.mapM go where @@ -227,7 +232,7 @@ -- | Add haddock information to the stream of @DumpPackage@s addHaddock :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b) m (DumpPackage a Bool) + -> Conduit (DumpPackage a b c) m (DumpPackage a Bool c) addHaddock (InstalledCache ref) = CL.mapM go where @@ -247,8 +252,44 @@ loop $ dpHaddockInterfaces dp return dp { dpHaddock = h } +-- | Add debugging symbol information to the stream of @DumpPackage@s +addSymbols :: MonadIO m + => InstalledCache + -> Conduit (DumpPackage a b c) m (DumpPackage a b Bool) +addSymbols (InstalledCache ref) = + CL.mapM go + where + go dp = do + InstalledCacheInner m <- liftIO $ readIORef ref + let gid = dpGhcPkgId dp + s <- case Map.lookup gid m of + Just installed -> return (installedCacheSymbols installed) + Nothing | null (dpLibraries dp) -> return True + Nothing -> do + let lib = T.unpack . head $ dpLibraries dp + liftM or . mapM (\dir -> liftIO $ hasDebuggingSymbols dir lib) $ dpLibDirs dp + return dp { dpSymbols = s } + +hasDebuggingSymbols :: FilePath -- ^ library directory + -> String -- ^ name of library + -> IO Bool +hasDebuggingSymbols dir lib = do + let path = concat [dir, "/lib", lib, ".a"] + exists <- doesFileExist path + if not exists then return False + else case OS.buildOS of + OS.OSX -> liftM (any (isPrefixOf "0x") . lines) $ + readProcess "dwarfdump" [path] "" + OS.Linux -> liftM (any (isPrefixOf "Contents") . lines) $ + readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] "" + OS.FreeBSD -> liftM (any (isPrefixOf "Contents") . lines) $ + readProcess "readelf" ["--debug-dump=info", "--dwarf-depth=1", path] "" + OS.Windows -> return False -- No support, so it can't be there. + _ -> return False + + -- | Dump information for a single package -data DumpPackage profiling haddock = DumpPackage +data DumpPackage profiling haddock symbols = DumpPackage { dpGhcPkgId :: !GhcPkgId , dpPackageIdent :: !PackageIdentifier , dpLibDirs :: ![FilePath] @@ -259,6 +300,7 @@ , dpHaddockHtml :: !(Maybe FilePath) , dpProfiling :: !profiling , dpHaddock :: !haddock + , dpSymbols :: !symbols , dpIsExposed :: !Bool } deriving (Show, Eq, Ord) @@ -280,7 +322,7 @@ -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m - => Conduit Text m (DumpPackage () ()) + => Conduit Text m (DumpPackage () () ()) conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume let m = Map.fromList pairs @@ -339,6 +381,7 @@ , dpHaddockHtml = listToMaybe haddockHtml , dpProfiling = () , dpHaddock = () + , dpSymbols = () , dpIsExposed = exposed == ["True"] } diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -17,7 +17,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Dealing with the 00-index file and all its cabal files. +-- | Dealing with the 01-index file and all its cabal files. module Stack.PackageIndex ( updateAllIndices , getPackageCaches @@ -30,21 +30,25 @@ import qualified Codec.Archive.Tar as Tar import Control.Exception (Exception) import Control.Exception.Safe (tryIO) -import Control.Monad (unless, when, liftM, void) +import Control.Monad (unless, when, liftM, void, guard) import Control.Monad.Catch (throwM) import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (logDebug, logInfo, logWarn, logError) -import Control.Monad.Reader (asks) import Control.Monad.Trans.Control +import Crypto.Hash as Hash (hashlazy, Digest, SHA1) import Data.Aeson.Extended +import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import Data.Conduit (($$), (=$)) -import Data.Conduit.Binary (sinkHandle, sourceHandle) +import Data.Conduit (($$), (=$), (.|), runConduitRes) +import Data.Conduit.Binary (sinkHandle, sourceHandle, sourceFile, sinkFile) import Data.Conduit.Zlib (ungzip) import Data.Foldable (forM_) import Data.IORef import Data.Int (Int64) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Monoid @@ -56,18 +60,29 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Unsafe (unsafeTail) +import Data.Time (getCurrentTime) import Data.Traversable (forM) import Data.Typeable (Typeable) +import qualified Hackage.Security.Client as HS +import qualified Hackage.Security.Client.Repository.Cache as HS +import qualified Hackage.Security.Client.Repository.Remote as HS +import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS +import qualified Hackage.Security.Util.Path as HS +import qualified Hackage.Security.Util.Pretty as HS +import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Download +import Network.URI (parseURI) import Path (mkRelDir, mkRelFile, parent, parseRelDir, toFilePath, parseAbsFile, ()) import Path.IO import Prelude -- Fix AMP warning +import Stack.Types.BuildPlan (GitSHA1 (..)) import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.StackT import Stack.Types.Version +import qualified System.Directory as D import System.FilePath (takeBaseName, (<.>)) import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile) import System.Process.Read (EnvOverride, ReadProcessException(..), doesExecutableExist, readProcessNull, tryProcessStdout) @@ -79,7 +94,7 @@ :: (StackMiniM env m, HasConfig env) => EnvOverride -> PackageIndex - -> m (Map PackageIdentifier PackageCache) + -> m PackageCacheMap populateCache menv index = do requireIndex menv index -- This uses full on lazy I/O instead of ResourceT to provide some @@ -88,8 +103,8 @@ let loadPIS = do $logSticky "Populating index cache ..." lbs <- liftIO $ L.readFile $ Path.toFilePath path - loop 0 Map.empty (Tar.read lbs) - pis <- loadPIS `C.catch` \e -> do + loop 0 (Map.empty, HashMap.empty) (Tar.read lbs) + (pis, gitPIs) <- loadPIS `C.catch` \e -> do $logWarn $ "Exception encountered when parsing index tarball: " <> T.pack (show (e :: Tar.FormatError)) $logWarn "Automatically updating index and trying again" @@ -103,42 +118,68 @@ $logStickyDone "Populated index cache." - return pis + return $ PackageCacheMap pis gitPIs where - loop !blockNo !m (Tar.Next e es) = - loop (blockNo + entrySizeInBlocks e) (goE blockNo m e) es - loop _ m Tar.Done = return m + loop !blockNo (!m, !hm) (Tar.Next e es) = + loop (blockNo + entrySizeInBlocks e) (goE blockNo m hm e) es + loop _ (m, hm) Tar.Done = return (m, hm) loop _ _ (Tar.Fail e) = throwM e - goE blockNo m e = + goE blockNo m hm e = case Tar.entryContent e of Tar.NormalFile lbs size -> - case parseNameVersion $ Tar.entryPath e of - Just (ident, ".cabal") -> addCabal ident size - Just (ident, ".json") -> addJSON ident lbs - _ -> m - _ -> m + case parseNameVersionSuffix $ Tar.entryPath e of + Just (ident, ".cabal") -> addCabal lbs ident size + Just (ident, ".json") -> (addJSON id ident lbs, hm) + _ -> + case parsePackageJSON $ Tar.entryPath e of + Just ident -> (addJSON unHSPackageDownload ident lbs, hm) + Nothing -> (m, hm) + _ -> (m, hm) where - addCabal ident size = Map.insertWith - (\_ pcOld -> pcNew { pcDownload = pcDownload pcOld }) - ident - pcNew - m + addCabal lbs ident size = + ( Map.insertWith + (\_ pcOld -> pcNew { pcDownload = pcDownload pcOld }) + ident + pcNew + m + , HashMap.insert gitSHA1 offsetSize hm + ) where pcNew = PackageCache - { pcOffset = (blockNo + 1) * 512 - , pcSize = size + { pcOffsetSize = offsetSize , pcDownload = Nothing } - addJSON ident lbs = + offsetSize = OffsetSize + ((blockNo + 1) * 512) + size + + -- Calculate the Git SHA1 of the contents. This uses the + -- Git algorithm of prepending "blob \0" to the raw + -- contents. We use this to be able to share the same SHA + -- information between the Git and tarball backends. + gitSHA1 = GitSHA1 $ Mem.convertToBase Mem.Base16 $ hashSHA1 $ L.fromChunks + $ "blob " + : S8.pack (show $ L.length lbs) + : "\0" + : L.toChunks lbs + + hashSHA1 :: L.ByteString -> Hash.Digest Hash.SHA1 + hashSHA1 = Hash.hashlazy + + addJSON :: FromJSON a + => (a -> PackageDownload) + -> PackageIdentifier + -> L.ByteString + -> Map PackageIdentifier PackageCache + addJSON unwrap ident lbs = case decode lbs of Nothing -> m - Just !pd -> Map.insertWith + Just (unwrap -> pd) -> Map.insertWith (\_ pc -> pc { pcDownload = Just pd }) ident PackageCache - { pcOffset = 0 - , pcSize = 0 + { pcOffsetSize = OffsetSize 0 0 , pcDownload = Just pd } m @@ -156,11 +197,19 @@ p <- parsePackageName p' (v', t5) <- breakSlash t3 v <- parseVersion v' + return (p', p, v, t5) + + parseNameVersionSuffix t1 = do + (p', p, v, t5) <- parseNameVersion t1 let (t6, suffix) = T.break (== '.') t5 - if t6 == p' - then return (PackageIdentifier p v, suffix) - else Nothing + guard $ t6 == p' + return (PackageIdentifier p v, suffix) + parsePackageJSON t1 = do + (_, p, v, t5) <- parseNameVersion t1 + guard $ t5 == "package.json" + return $ PackageIdentifier p v + data PackageIndexException = GitNotAvailable IndexName | MissingRequiredHashes IndexName PackageIdentifier @@ -194,22 +243,36 @@ => EnvOverride -> m () updateAllIndices menv = do clearPackageCaches - asks (configPackageIndices . getConfig) >>= mapM_ (updateIndex menv) + view packageIndicesL >>= mapM_ (updateIndex menv) -- | Update the index tarball updateIndex :: (StackMiniM env m, HasConfig env) => EnvOverride -> PackageIndex -> m () updateIndex menv index = do let name = indexName index - logUpdate mirror = $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> mirror <> ") ..." + sloc = simplifyIndexLocation $ indexLocation index + $logSticky $ "Updating package index " + <> indexNameText (indexName index) + <> " (mirrored at " + <> (case sloc of + SILGit url -> url + SILHttp url _ -> url) + <> ") ..." git <- isGitInstalled menv - case (git, indexLocation index) of - (True, ILGit url) -> logUpdate url >> updateIndexGit menv name index url - (True, ILGitHttp url _) -> logUpdate url >> updateIndexGit menv name index url - (_, ILHttp url) -> logUpdate url >> updateIndexHTTP name index url - (False, ILGitHttp _ url) -> logUpdate url >> updateIndexHTTP name index url - (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name) + case (git, sloc) of + (True, SILGit url) -> updateIndexGit menv name index url + (False, SILGit _) -> throwM (GitNotAvailable name) + (_, SILHttp url HTVanilla) -> updateIndexHTTP name index url + (_, SILHttp url (HTHackageSecurity hs)) -> updateIndexHackageSecurity name index url hs + -- Copy to the 00-index.tar filename for backwards + -- compatibility. First wipe out the cache file if present. + tarFile <- configPackageIndex name + oldTarFile <- configPackageIndexOld name + oldCacheFile <- configPackageIndexCacheOld name + ignoringAbsence (removeFile oldCacheFile) + runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) + -- | Update the index Git repo and the index tarball updateIndexGit :: (StackMiniM env m, HasConfig env) => EnvOverride @@ -341,6 +404,64 @@ $ "You have enabled GPG verification of the package index, " <> "but GPG verification only works with Git downloading" +-- | Update the index tarball via Hackage Security +updateIndexHackageSecurity + :: (StackMiniM env m, HasConfig env) + => IndexName + -> PackageIndex + -> Text -- ^ base URL + -> HackageSecurity + -> m () +updateIndexHackageSecurity indexName' index url (HackageSecurity keyIds threshold) = do + baseURI <- + case parseURI $ T.unpack url of + Nothing -> error $ "Invalid Hackage Security base URL: " ++ T.unpack url + Just x -> return x + manager <- liftIO getGlobalManager + root <- configPackageIndexRoot indexName' + logTUF <- embed_ ($logInfo . T.pack . HS.pretty) + let withRepo = HS.withRepository + (HS.makeHttpLib manager) + [baseURI] + HS.defaultRepoOpts + HS.Cache + { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root + , HS.cacheLayout = HS.cabalCacheLayout + -- Have Hackage Security write to a temporary file + -- to avoid invalidating the cache... continued + -- below at case didUpdate + { HS.cacheLayoutIndexTar = HS.rootPath $ HS.fragment "01-index.tar-tmp" + } + } + HS.hackageRepoLayout + HS.hackageIndexLayout + logTUF + didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do + needBootstrap <- HS.requiresBootstrap repo + when needBootstrap $ do + HS.bootstrap + repo + (map (HS.KeyId . T.unpack) keyIds) + (HS.KeyThreshold (fromIntegral threshold)) + now <- getCurrentTime + HS.checkForUpdates repo (Just now) + + case didUpdate of + HS.HasUpdates -> do + -- The index actually updated. Delete the old cache, and + -- then move the temporary unpacked file to its real + -- location + tar <- configPackageIndex indexName' + deleteCache indexName' + liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar) + $logInfo "Updated package list downloaded" + HS.NoUpdates -> $logInfo "No updates to your package list were found" + + when (indexGpgVerify index) + $ $logWarn + $ "You have enabled GPG verification of the package index, " <> + "but GPG verification only works with Git downloading" + -- | Is the git executable installed? isGitInstalled :: MonadIO m => EnvOverride @@ -365,7 +486,7 @@ getPackageVersionsIO = do getCaches <- getPackageCachesIO return $ \name -> - fmap (lookupPackageVersions name) getCaches + fmap (lookupPackageVersions name . fst) getCaches -- | Get the known versions for a given package from the package caches. -- @@ -375,7 +496,7 @@ => PackageName -> m (Set Version) getPackageVersions pkgName = - fmap (lookupPackageVersions pkgName) getPackageCaches + fmap (lookupPackageVersions pkgName . fst) getPackageCaches lookupPackageVersions :: PackageName -> Map PackageIdentifier a -> Set Version lookupPackageVersions pkgName pkgCaches = @@ -388,7 +509,8 @@ -- has been found. getPackageCachesIO :: (StackMiniM env m, HasConfig env) - => m (IO (Map PackageIdentifier (PackageIndex, PackageCache))) + => m (IO ( Map PackageIdentifier (PackageIndex, PackageCache) + , HashMap GitSHA1 (PackageIndex, OffsetSize))) getPackageCachesIO = toIO getPackageCaches where toIO :: (MonadIO m, MonadBaseControl IO m) => m a -> m (IO a) @@ -407,22 +529,24 @@ -- feel free to call this function multiple times. getPackageCaches :: (StackMiniM env m, HasConfig env) - => m (Map PackageIdentifier (PackageIndex, PackageCache)) + => m ( Map PackageIdentifier (PackageIndex, PackageCache) + , HashMap GitSHA1 (PackageIndex, OffsetSize) + ) getPackageCaches = do menv <- getMinimalEnvOverride - config <- askConfig + config <- view configL mcached <- liftIO $ readIORef (configPackageCaches config) case mcached of Just cached -> return cached Nothing -> do result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do fp <- configPackageIndexCache (indexName index) - PackageCacheMap pis' <- - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v1" "aHzcZ6_w3rL6NtEJUqEfh6fcjAc=" + PackageCacheMap pis' gitPIs <- + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "WlAvAaRXlIMkjSmg5G3dD16UpT8=" :: VersionConfig PackageCacheMap)) fp - (liftM PackageCacheMap (populateCache menv index)) - return (fmap (index,) pis') + (populateCache menv index) + return (fmap (index,) pis', fmap (index,) gitPIs) liftIO $ writeIORef (configPackageCaches config) (Just result) return result @@ -430,7 +554,7 @@ -- hackage index is updated. clearPackageCaches :: (StackMiniM env m, HasConfig env) => m () clearPackageCaches = do - cacheRef <- asks (configPackageCaches . getConfig) + cacheRef <- view packageCachesL liftIO $ writeIORef cacheRef Nothing --------------- Lifted from cabal-install, Distribution.Client.Tar: diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -18,6 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T +import Lens.Micro (lens) import qualified Options.Applicative as OA import Path import Path.Extra @@ -38,7 +39,7 @@ path keys = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. - bc <- asks (getBuildConfig . getEnvConfig) + bc <- view $ envConfigL.buildConfigL -- This is the modified 'bin-path', -- including the local GHC or MSYS if not configured to operate on -- global GHC. @@ -48,12 +49,13 @@ snap <- packageDatabaseDeps plocal <- packageDatabaseLocal extra <- packageDatabaseExtra - global <- GhcPkg.getGlobalDB menv =<< getWhichCompiler + whichCompiler <- view $ actualCompilerVersionL.whichCompilerL + global <- GhcPkg.getGlobalDB menv whichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal distDir <- distRelativeDir hpcDir <- hpcReportDir - compiler <- getCompilerPath =<< getWhichCompiler + compiler <- getCompilerPath whichCompiler let deprecated = filter ((`elem` keys) . fst) deprecatedPathKeys liftIO $ forM_ deprecated $ \(oldOption, newOption) -> T.hPutStrLn stderr $ T.unlines [ "" @@ -114,6 +116,12 @@ , piCompiler :: Path Abs File } +instance HasPlatform PathInfo +instance HasConfig PathInfo +instance HasBuildConfig PathInfo where + buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y }) + . buildConfigL + -- | The paths of interest to a user. The first tuple string is used -- for a description that the optparse flag uses, and the second -- string as a machine-readable key and also for @--foo@ flags. The user @@ -127,19 +135,19 @@ paths = [ ( "Global stack root directory" , T.pack stackRootOptionName - , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig ) + , view $ stackRootL.to toFilePathNoTrailingSep.to T.pack) , ( "Project root (derived from stack.yaml file)" , "project-root" - , T.pack . toFilePathNoTrailingSep . bcRoot . piBuildConfig ) + , view $ projectRootL.to toFilePathNoTrailingSep.to T.pack) , ( "Configuration location (where the stack.yaml file is)" , "config-location" - , T.pack . toFilePath . bcStackYaml . piBuildConfig ) + , view $ stackYamlL.to toFilePath.to T.pack) , ( "PATH environment variable" , "bin-path" , T.pack . intercalate [FP.searchPathSeparator] . eoPath . piEnvOverride ) , ( "Install location for GHC and other core tools" , "programs" - , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig ) + , view $ configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack) , ( "Compiler binary (e.g. ghc)" , "compiler-exe" , T.pack . toFilePath . piCompiler ) @@ -148,13 +156,13 @@ , T.pack . toFilePathNoTrailingSep . parent . piCompiler ) , ( "Local bin dir where stack installs executables (e.g. ~/.local/bin)" , "local-bin" - , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) + , view $ configL.to configLocalBin.to toFilePathNoTrailingSep.to T.pack) , ( "Extra include directories" , "extra-include-dirs" - , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . view configL ) , ( "Extra library directories" , "extra-library-dirs" - , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . view configL ) , ( "Snapshot package database" , "snapshot-pkg-db" , T.pack . toFilePathNoTrailingSep . piSnapDb ) @@ -187,13 +195,13 @@ , T.pack . toFilePathNoTrailingSep . piHpcDir ) , ( "DEPRECATED: Use '--local-bin' instead" , "local-bin-path" - , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) + , T.pack . toFilePathNoTrailingSep . configLocalBin . view configL ) , ( "DEPRECATED: Use '--programs' instead" , "ghc-paths" - , T.pack . toFilePathNoTrailingSep . configLocalPrograms . bcConfig . piBuildConfig ) + , T.pack . toFilePathNoTrailingSep . configLocalPrograms . view configL ) , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead" , T.pack deprecatedStackRootOptionName - , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig ) + , T.pack . toFilePathNoTrailingSep . view stackRootL ) ] deprecatedPathKeys :: [(Text, Text)] diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -50,7 +50,7 @@ :: (HasLogOptions env, MonadReader env m, Display a, HasAnsiAnn (Ann a)) => a -> m T.Text displayWithColor x = do - useAnsi <- asks (logUseColor . getLogOptions) + useAnsi <- liftM logUseColor $ view logOptionsL return $ if useAnsi then displayAnsi x else displayPlain x -- TODO: switch to using implicit callstacks once 7.8 support is dropped diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -43,7 +43,7 @@ loadCompilerVersion go lc = do bconfig <- runStackTGlobal () go $ lcLoadBuildConfig lc (globalCompiler go) - return $ bcWantedCompiler bconfig + return $ view wantedCompilerVersionL bconfig -- | Enforce mutual exclusion of every action running via this -- function, on this path, on this users account. @@ -108,7 +108,10 @@ -> 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 @@ -207,9 +210,13 @@ -> StackT MiniConfig IO () -> IO () withMiniConfigAndLock go@GlobalOpts{..} inner = do - miniConfig <- runStackTGlobal () go $ do - lc <- loadConfigMaybeProject globalConfigMonoid globalResolver Nothing - loadMiniConfig (lcConfig lc) + miniConfig <- + runStackTGlobal () go $ + (loadMiniConfig . lcConfig) <$> + loadConfigMaybeProject + globalConfigMonoid + globalResolver + LCSNoProject runStackTGlobal miniConfig go inner -- | Unlock a lock file, if the value is Just diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -22,7 +22,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import Control.Monad.Trans.Control (liftBaseWith) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -69,7 +68,7 @@ -- | Special exception to throw when you want to fail because of bad results -- of package check. -data CheckException +newtype CheckException = CheckException (NonEmpty Check.PackageCheck) deriving (Typeable) @@ -92,7 +91,7 @@ -> Path Abs Dir -- ^ Path to local package -> m (FilePath, L.ByteString) -- ^ Filename and tarball contents getSDistTarball mpvpBounds pkgDir = do - config <- asks getConfig + config <- view configL let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds tweakCabal = pvpBounds /= PvpBoundsNone pkgFp = toFilePath pkgDir @@ -137,6 +136,7 @@ (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False + , getInstalledSymbols = False } sourceMap let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Script.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Stack.Script + ( scriptCmd + ) where + +import Control.Exception (assert) +import Control.Exception.Safe (throwM) +import Control.Monad (unless, forM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Conduit.List as CL +import Data.Foldable (fold) +import Data.List.Split (splitWhen) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Store.VersionTagged (versionedDecodeOrLoad) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Path +import Path.IO +import qualified Stack.Build +import Stack.BuildPlan (loadBuildPlan) +import Stack.Exec +import Stack.GhcPkg (ghcPkgExeName) +import Stack.Options.ScriptParser +import Stack.Runners +import Stack.Types.BuildPlan +import Stack.Types.Compiler +import Stack.Types.Config +import Stack.Types.PackageName +import Stack.Types.Resolver +import Stack.Types.StackT +import System.FilePath (dropExtension, replaceExtension) +import System.Process.Read + +-- | Run a Stack Script +scriptCmd :: ScriptOpts -> GlobalOpts -> IO () +scriptCmd opts 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. Note that in this functions we use + -- logError instead of logWarn because, when using the + -- interpreter mode, only error messages are shown. See: + -- https://github.com/commercialhaskell/stack/issues/3007 + case globalStackYaml go' of + SYLOverride fp -> $logError $ 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 + + (targetsSet, coresSet) <- + case soPackages opts of + [] -> do + $logError "No packages provided, using experimental import parser" + getPackagesFromImports (globalResolver go) (soFile opts) + packages -> do + let targets = concatMap wordsComma packages + targets' <- mapM parsePackageNameFromString targets + return (Set.fromList targets', Set.empty) + + unless (Set.null targetsSet) $ 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 (Set.map packageNameString targetsSet) installed + then $logDebug "All packages already installed" + else do + $logDebug "Missing packages, performing installation" + Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + { boptsCLITargets = map packageNameText $ Set.toList targetsSet + } + + let ghcArgs = concat + [ ["-hide-all-packages"] + , map (\x -> "-package" ++ x) + $ Set.toList + $ Set.insert "base" + $ Set.map packageNameString (Set.union targetsSet coresSet) + , case soCompile opts of + SEInterpret -> [] + SECompile -> [] + SEOptimize -> ["-O2"] + ] + munlockFile lk -- Unlock before transferring control away. + case soCompile opts of + 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 + sinkProcessStdout + (Just dir) + menv + (compilerExeName wc) + (ghcArgs ++ [soFile opts]) + CL.sinkNull + exec menv (toExeName $ toFilePath file) (soArgs opts) + where + toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse + + -- Like words, but splits on both commas and spaces + wordsComma = splitWhen (\c -> c == ' ' || c == ',') + + toExeName fp = + if isWindows + then replaceExtension fp "exe" + else dropExtension fp + +isWindows :: Bool +#ifdef WINDOWS +isWindows = True +#else +isWindows = False +#endif + +-- | Returns packages that need to be installed, and all of the core +-- packages. Reason for the core packages: + +-- Ideally we'd have the list of modules per core package listed in +-- the build plan, but that doesn't exist yet. Next best would be to +-- list the modules available at runtime, but that gets tricky with when we install GHC. Instead, we'll just list all core packages +getPackagesFromImports :: Maybe AbstractResolver + -> FilePath + -> StackT EnvConfig IO (Set PackageName, Set PackageName) +getPackagesFromImports Nothing _ = throwM NoResolverWhenUsingNoLocalConfig +getPackagesFromImports (Just (ARResolver (ResolverSnapshot name))) scriptFP = do + (pns1, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP + mi <- loadModuleInfo name + pns2 <- + if Set.null mns + then return Set.empty + else do + pns <- forM (Set.toList mns) $ \mn -> + case Map.lookup mn $ miModules mi of + Just pns -> + case Set.toList pns of + [] -> assert False $ return Set.empty + [pn] -> return $ Set.singleton pn + pns' -> error $ concat + [ "Module " + , S8.unpack $ unModuleName mn + , " appears in multiple packages: " + , unwords $ map packageNameString pns' + ] + Nothing -> return Set.empty + return $ Set.unions pns `Set.difference` blacklist + return (Set.union pns1 pns2, modifyForWindows $ miCorePackages mi) + where + modifyForWindows + | isWindows = Set.insert $(mkPackageName "Win32") . Set.delete $(mkPackageName "unix") + | otherwise = id + +getPackagesFromImports (Just (ARResolver (ResolverCompiler _))) _ = return (Set.empty, Set.empty) +getPackagesFromImports (Just aresolver) _ = throwM $ InvalidResolverForNoLocalConfig $ show aresolver + +-- | The Stackage project introduced the concept of hidden packages, +-- to deal with conflicting module names. However, this is a +-- relatively recent addition (at time of writing). See: +-- http://www.snoyman.com/blog/2017/01/conflicting-module-names. To +-- kick this thing off a bit better, we're included a blacklist of +-- packages that should never be auto-parsed in. +blacklist :: Set PackageName +blacklist = Set.fromList + [ $(mkPackageName "async-dejafu") + , $(mkPackageName "monads-tf") + , $(mkPackageName "crypto-api") + , $(mkPackageName "fay-base") + , $(mkPackageName "hashmap") + , $(mkPackageName "hxt-unicode") + , $(mkPackageName "hledger-web") + , $(mkPackageName "plot-gtk3") + , $(mkPackageName "gtk3") + , $(mkPackageName "regex-pcre-builtin") + , $(mkPackageName "regex-compat-tdfa") + , $(mkPackageName "log") + , $(mkPackageName "zip") + , $(mkPackageName "monad-extras") + , $(mkPackageName "control-monad-free") + , $(mkPackageName "prompt") + , $(mkPackageName "kawhi") + , $(mkPackageName "language-c") + , $(mkPackageName "gl") + , $(mkPackageName "svg-tree") + , $(mkPackageName "Glob") + , $(mkPackageName "nanospec") + , $(mkPackageName "HTF") + , $(mkPackageName "courier") + , $(mkPackageName "newtype-generics") + , $(mkPackageName "objective") + , $(mkPackageName "binary-ieee754") + , $(mkPackageName "rerebase") + , $(mkPackageName "cipher-aes") + , $(mkPackageName "cipher-blowfish") + , $(mkPackageName "cipher-camellia") + , $(mkPackageName "cipher-des") + , $(mkPackageName "cipher-rc4") + , $(mkPackageName "crypto-cipher-types") + , $(mkPackageName "crypto-numbers") + , $(mkPackageName "crypto-pubkey") + , $(mkPackageName "crypto-random") + , $(mkPackageName "cryptohash") + , $(mkPackageName "cryptohash-conduit") + , $(mkPackageName "cryptohash-md5") + , $(mkPackageName "cryptohash-sha1") + , $(mkPackageName "cryptohash-sha256") + ] + +toModuleInfo :: BuildPlan -> ModuleInfo +toModuleInfo bp = ModuleInfo + { miCorePackages = Map.keysSet $ siCorePackages $ bpSystemInfo bp + , miModules = + Map.unionsWith Set.union + $ map ((\(pn, mns) -> + Map.fromList + $ map (\mn -> (ModuleName $ encodeUtf8 mn, Set.singleton pn)) + $ Set.toList mns) . fmap (sdModules . ppDesc)) + $ filter (\(pn, pp) -> + not (pcHide $ ppConstraints pp) && + pn `Set.notMember` blacklist) + $ Map.toList (bpPackages bp) + } + +-- | Where to store module info caches +moduleInfoCache :: SnapName -> StackT EnvConfig IO (Path Abs File) +moduleInfoCache name = do + root <- view stackRootL + platform <- platformGhcVerOnlyRelDir + name' <- parseRelDir $ T.unpack $ renderSnapName name + -- These probably can't vary at all based on platform, even in the + -- future, so it's safe to call this unnecessarily paranoid. + return (root $(mkRelDir "script") name' platform $(mkRelFile "module-info.cache")) + +loadModuleInfo :: SnapName -> StackT EnvConfig IO ModuleInfo +loadModuleInfo name = do + path <- moduleInfoCache name + $(versionedDecodeOrLoad moduleInfoVC) path $ toModuleInfo <$> loadBuildPlan name + +parseImports :: ByteString -> (Set PackageName, Set ModuleName) +parseImports = + fold . mapMaybe parseLine . S8.lines + where + stripPrefix x y + | x `S8.isPrefixOf` y = Just $ S8.drop (S8.length x) y + | otherwise = Nothing + + parseLine bs0 = do + bs1 <- stripPrefix "import " bs0 + let bs2 = S8.dropWhile (== ' ') bs1 + bs3 = fromMaybe bs2 $ stripPrefix "qualified " bs2 + case stripPrefix "\"" bs3 of + Just bs4 -> do + pn <- parsePackageNameFromString $ S8.unpack $ S8.takeWhile (/= '"') bs4 + Just (Set.singleton pn, Set.empty) + Nothing -> Just + ( Set.empty + , Set.singleton + $ ModuleName + $ S8.takeWhile (\c -> c /= ' ' && c /= '(') bs3 + ) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -38,10 +38,10 @@ import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, ReaderT (..), asks) +import Control.Monad.Reader (MonadReader, ReaderT (..)) import Control.Monad.State (get, put, modify) import Control.Monad.Trans.Control -import "cryptohash" Crypto.Hash (SHA1(SHA1)) +import "cryptonite" Crypto.Hash (SHA1(..)) import Data.Aeson.Extended import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -98,7 +98,6 @@ import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.Docker -import Stack.Types.Internal (envConfigBuildOpts, buildOptsInstallExes, buildOptsHaddock) import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT @@ -216,26 +215,29 @@ => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do - bconfig <- asks getBuildConfig - let platform = getPlatform bconfig - wc = whichCompiler (bcWantedCompiler bconfig) - sopts = SetupOpts - { soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig - , soptsUseSystem = configSystemGHC $ bcConfig bconfig - , soptsWantedCompiler = bcWantedCompiler bconfig - , soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig - , soptsStackYaml = Just $ bcStackYaml bconfig + config <- view configL + bconfig <- view buildConfigL + let stackYaml = bcStackYaml bconfig + platform <- view platformL + wcVersion <- view wantedCompilerVersionL + wc <- view $ wantedCompilerVersionL.whichCompilerL + let sopts = SetupOpts + { soptsInstallIfMissing = configInstallGHC config + , soptsUseSystem = configSystemGHC config + , soptsWantedCompiler = wcVersion + , soptsCompilerCheck = configCompilerCheck config + , soptsStackYaml = Just stackYaml , soptsForceReinstall = False , soptsSanityCheck = False - , soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig - , soptsSkipMsys = configSkipMsys $ bcConfig bconfig + , soptsSkipGhcCheck = configSkipGHCCheck config + , soptsSkipMsys = configSkipMsys config , soptsUpgradeCabal = False , soptsResolveMissingGHC = mResolveMissingGHC , soptsSetupInfoYaml = defaultSetupInfoYaml , soptsGHCBindistURL = Nothing } - (mghcBin, compilerBuild) <- ensureCompiler sopts + (mghcBin, compilerBuild, _) <- ensureCompiler sopts -- Modify the initial environment to include the GHC path, if a local GHC -- is being used @@ -251,8 +253,9 @@ $logDebug "Resolving package entries" packagesRef <- liftIO $ newIORef Nothing + bc <- view buildConfigL let envConfig0 = EnvConfig - { envConfigBuildConfig = bconfig + { envConfigBuildConfig = bc , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer , envConfigCompilerBuild = compilerBuild @@ -329,7 +332,7 @@ return EnvConfig { envConfigBuildConfig = bconfig { bcConfig = maybe id addIncludeLib mghcBin - (bcConfig bconfig) + (view configL bconfig) { configEnvOverride = getEnvOverride' } } , envConfigCabalVersion = cabalVer @@ -352,7 +355,7 @@ -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary ensureCompiler :: (StackM env m, HasConfig env, HasGHCVariant env) => SetupOpts - -> m (Maybe ExtraDirs, CompilerBuild) + -> m (Maybe ExtraDirs, CompilerBuild, Bool) ensureCompiler sopts = do let wc = whichCompiler (soptsWantedCompiler sopts) when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do @@ -371,7 +374,7 @@ getSystemCompiler menv0 wc else return Nothing - Platform expectedArch _ <- asks getPlatform + Platform expectedArch _ <- view platformL let canUseCompiler compilerVersion arch | soptsSkipGhcCheck sopts = True @@ -382,8 +385,8 @@ getSetupInfo' <- runOnce (getSetupInfo (soptsSetupInfoYaml sopts)) let getMmsys2Tool = do - platform <- asks getPlatform - localPrograms <- asks $ configLocalPrograms . getConfig + platform <- view platformL + localPrograms <- view $ configL.to configLocalPrograms installed <- listInstalled localPrograms case platform of @@ -394,7 +397,7 @@ | soptsInstallIfMissing sopts -> do si <- getSetupInfo' osKey <- getOSKey platform - config <- asks getConfig + config <- view configL VersionedDownloadInfo version info <- case Map.lookup osKey $ siMsys2 si of Just x -> return x @@ -412,12 +415,12 @@ (mtools, compilerBuild) <- if needLocal then do - localPrograms <- asks $ configLocalPrograms . getConfig + -- Install GHC + ghcVariant <- view ghcVariantL + config <- view configL + let localPrograms = configLocalPrograms config installed <- listInstalled localPrograms - -- Install GHC - ghcVariant <- asks getGHCVariant - config <- asks getConfig (installedCompiler, compilerBuild) <- case wc of Ghc -> do @@ -482,7 +485,7 @@ case mpaths of Nothing -> return menv0 Just ed -> do - config <- asks getConfig + config <- view configL m <- augmentPathMap (edBins ed) (unEnvOverride menv0) mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) @@ -498,7 +501,7 @@ when (soptsSanityCheck sopts) $ sanityCheck menv wc - return (mpaths, compilerBuild) + return (mpaths, compilerBuild, needLocal) -- | Determine which GHC build to use depending on which shared libraries are available -- on the system. @@ -507,7 +510,7 @@ => EnvOverride -> m CompilerBuild getGhcBuild menv = do - config <- asks getConfig + config <- view configL case configGHCBuild config of Just ghcBuild -> return ghcBuild Nothing -> determineGhcBuild @@ -531,7 +534,7 @@ -- -- Of course, could also try to make a static GHC bindist instead of all this rigamarole. - platform <- asks getPlatform + platform <- view platformL case platform of Platform _ Linux -> do -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well @@ -605,7 +608,7 @@ :: (StackM env m, HasConfig env) => Platform -> m (Path Abs File) ensureDockerStackExe containerPlatform = do - config <- asks getConfig + config <- view configL containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone) let programsPath = configLocalProgramsBase config containerPlatformDir tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion) @@ -626,9 +629,9 @@ -> m () upgradeCabal menv wc = do let name = $(mkPackageName "Cabal") - rmap <- resolvePackages menv Map.empty (Set.singleton name) + rmap <- resolvePackages menv Nothing Map.empty (Set.singleton name) newest <- - case Map.keys rmap of + case map rpIdent rmap of [] -> error "No Cabal library found in index, cannot upgrade" [PackageIdentifier name' version] | name == name' -> return version @@ -665,7 +668,7 @@ Just dir -> return dir runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing - platform <- asks getPlatform + platform <- view platformL let setupExe = toFilePath $ dir (case platform of Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") @@ -713,7 +716,7 @@ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env) => String -> m SetupInfo getSetupInfo stackSetupYaml = do - config <- asks getConfig + config <- view configL setupInfos <- mapM loadSetupInfo @@ -789,7 +792,7 @@ -> Maybe String -> m Tool downloadAndInstallCompiler ghcBuild si wanted@GhcVersion{} versionCheck mbindistURL = do - ghcVariant <- asks getGHCVariant + ghcVariant <- view ghcVariantL (selectedVersion, downloadInfo) <- case mbindistURL of Just bindistURL -> do case ghcVariant of @@ -805,7 +808,7 @@ case Map.lookup ghcKey $ siGHCs si of Nothing -> throwM $ UnknownOSKey ghcKey Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_ - config <- asks getConfig + config <- view configL let installer = case configPlatform config of Platform _ Cabal.Windows -> installGHCWindows selectedVersion @@ -824,8 +827,8 @@ let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion downloadAndInstallTool (configLocalPrograms config) si (gdiDownloadInfo downloadInfo) tool installer downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = do - config <- asks getConfig - ghcVariant <- asks getGHCVariant + config <- view configL + ghcVariant <- view ghcVariantL case (ghcVariant, compilerBuild) of (GHCStandard, CompilerBuildStandard) -> return () _ -> throwM GHCJSRequiresStandardVariant @@ -857,8 +860,8 @@ getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m) => CompilerBuild -> m Text getGhcKey ghcBuild = do - ghcVariant <- asks getGHCVariant - platform <- asks getPlatform + ghcVariant <- view ghcVariantL + platform <- view platformL osKey <- getOSKey platform return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) <> T.pack (compilerBuildSuffix ghcBuild) @@ -936,7 +939,7 @@ -> Path Abs Dir -> m () installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do - platform <- asks getPlatform + platform <- view platformL menv0 <- getMinimalEnvOverride menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0)) $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) @@ -1009,7 +1012,7 @@ -> Path Abs Dir -> m () installGHCJS si archiveFile archiveType _tempDir destDir = do - platform <- asks getPlatform + platform <- view platformL menv0 <- getMinimalEnvOverride -- This ensures that locking is disabled for the invocations of -- stack below. @@ -1070,8 +1073,8 @@ _ -> return Nothing $logSticky "Installing GHCJS (this will take a long time) ..." - runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True $ - set (envConfigBuildOpts.buildOptsHaddock) False envConfig') $ + runInnerStackT (set (buildOptsL.buildOptsInstallExesL) True $ + set (buildOptsL.buildOptsHaddockL) False envConfig') $ build (\_ -> return ()) Nothing defaultBuildOptsCLI -- Copy over *.options files needed on windows. forM_ mwindowsInstallDir $ \dir -> do @@ -1092,7 +1095,7 @@ return () Left (ProcessFailed _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err -> if not shouldBoot then throwM GHCJSNotBooted else do - config <- asks getConfig + config <- view configL destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv) let stackYaml = destDir $(mkRelFile "src/stack.yaml") -- TODO: Remove 'actualStackYaml' and just use @@ -1121,7 +1124,7 @@ => Version -> Path Abs File -> Path Abs Dir -> m () bootGhcjs ghcjsVersion stackYaml destDir = do envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) - menv <- liftIO $ configEnvOverride (getConfig envConfig) defaultEnvSettings + menv <- liftIO $ configEnvOverride (view configL envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. mcabal <- getCabalInstallVersion menv shouldInstallCabal <- case mcabal of @@ -1152,7 +1155,7 @@ return True | otherwise -> return False let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False } - menv' <- liftIO $ configEnvOverride (getConfig envConfig) envSettings + menv' <- liftIO $ configEnvOverride (view configL envConfig) envSettings when shouldInstallCabal $ do $logInfo "Building a local copy of cabal-install from source." runInnerStackT envConfig $ @@ -1184,7 +1187,7 @@ , configMonoidLocalBinPath = First (Just (toFilePath binPath)) }) Nothing - (Just stackYaml) + (SYLOverride stackYaml) bconfig <- lcLoadBuildConfig lc Nothing runInnerStackT bconfig $ setupEnv Nothing @@ -1266,7 +1269,7 @@ -- I couldn't find this officially documented anywhere, but you need to run -- the MSYS shell once in order to initialize some pacman stuff. Once that -- run happens, you can just run commands as usual. - platform <- asks getPlatform + platform <- view platformL menv0 <- getMinimalEnvOverride newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS" newEnv <- augmentPathMap [destDir $(mkRelDir "usr") $(mkRelDir "bin")] @@ -1335,7 +1338,7 @@ => SetupInfo -> m (Path Abs Dir -> Path Abs File -> n ()) setup7z si = do - dir <- asks $ configLocalPrograms . getConfig + dir <- view $ configL.to configLocalPrograms ensureDir dir let exe = dir $(mkRelFile "7z.exe") dll = dir $(mkRelFile "7z.dll") @@ -1524,7 +1527,7 @@ else legacyLocale where legacyLocale = do - Platform _ os <- asks getPlatform + Platform _ os <- view platformL if os == Cabal.Windows then -- On Windows, locale is controlled by the code page, so we don't set any environment @@ -1673,7 +1676,7 @@ preferredPlatforms :: (MonadReader env m, HasPlatform env) => m [(Bool, String)] preferredPlatforms = do - Platform arch' os' <- asks getPlatform + Platform arch' os' <- view platformL (isWindows, os) <- case os' of Cabal.Linux -> return (False, "linux") @@ -1733,7 +1736,7 @@ $logInfo "Download complete, testing executable" - platform <- asks getPlatform + platform <- view platformL liftIO $ do #if !WINDOWS diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -25,7 +25,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import Data.List hiding (concat, elem, maximumBy) @@ -122,7 +122,7 @@ => Tool -> m ExtraDirs extraDirs tool = do - config <- asks getConfig + config <- view configL dir <- installDir (configLocalPrograms config) tool case (configPlatform config, toolNameString tool) of (Platform _ Cabal.Windows, isGHC -> True) -> return mempty diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -85,8 +85,8 @@ -> Maybe (Path Abs File) -> m () setup SetupCmdOpts{..} wantedCompiler compilerCheck mstack = do - Config{..} <- asks getConfig - mpaths <- fst <$> ensureCompiler SetupOpts + Config{..} <- view configL + (_, _, sandboxedGhc) <- ensureCompiler SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = configSystemGHC && not scoForceReinstall , soptsWantedCompiler = wantedCompiler @@ -104,9 +104,9 @@ let compiler = case wantedCompiler of GhcVersion _ -> "GHC" GhcjsVersion {} -> "GHCJS" - case mpaths of - Nothing -> $logInfo $ "stack will use the " <> compiler <> " on your PATH" - Just _ -> $logInfo $ "stack will use a sandboxed " <> compiler <> " it installed" + if sandboxedGhc + then $logInfo $ "stack will use a sandboxed " <> compiler <> " it installed" + else $logInfo $ "stack will use the " <> compiler <> " on your PATH" $logInfo "For more information on paths, see 'stack path' and 'stack exec env'" $logInfo $ "To use this " <> compiler <> " and packages outside of a project, consider using:" $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -27,7 +27,6 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks) import Data.Aeson.Extended ( WithJSONWarnings(..), object, (.=), toJSON , logJSONWarnings) import qualified Data.ByteString as S @@ -241,7 +240,7 @@ -> Map PackageName Version -- ^ constraints -> m [Text] getCabalConfig dir constraintType constraints = do - indices <- asks $ configPackageIndices . getConfig + indices <- view $ configL.to configPackageIndices remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir return $ cache : remotes ++ map goConstraint (Map.toList constraints) @@ -249,10 +248,15 @@ goIndex index = do src <- configPackageIndex $ indexName index let dstdir = dir FP. T.unpack (indexNameText $ indexName index) - dst = dstdir FP. "00-index.tar" + -- NOTE: see https://github.com/commercialhaskell/stack/issues/2888 + -- for why we are pretending that a 01-index.tar is actually a + -- 00-index.tar file. + dst0 = dstdir FP. "00-index.tar" + dst1 = dstdir FP. "01-index.tar" liftIO $ void $ tryIO $ do D.createDirectoryIfMissing True dstdir - D.copyFile (toFilePath src) dst + D.copyFile (toFilePath src) dst0 + D.copyFile (toFilePath src) dst1 return $ T.concat [ "remote-repo: " , indexNameText $ indexName index @@ -283,8 +287,8 @@ , "install the compiler or '--system-ghc' to use a suitable " , "compiler available on your PATH." ] - config <- asks getConfig - fst <$> ensureCompiler SetupOpts + config <- view configL + (dirs, _, _) <- ensureCompiler SetupOpts { soptsInstallIfMissing = configInstallGHC config , soptsUseSystem = configSystemGHC config , soptsWantedCompiler = compiler @@ -300,6 +304,7 @@ , soptsSetupInfoYaml = defaultSetupInfoYaml , soptsGHCBindistURL = Nothing } + return dirs setupCabalEnv :: (StackM env m, HasConfig env, HasGHCVariant env) @@ -311,7 +316,7 @@ envMap <- removeHaskellEnvVars <$> augmentPathMap (maybe [] edBins mpaths) (unEnvOverride menv0) - platform <- asks getPlatform + platform <- view platformL menv <- mkEnvOverride platform envMap mcabal <- findExecutable menv "cabal" @@ -617,7 +622,7 @@ => Bool -- ^ modify stack.yaml? -> m () solveExtraDeps modStackYaml = do - bconfig <- asks getBuildConfig + bconfig <- view buildConfigL let stackYaml = bcStackYaml bconfig relStackYaml <- prettyPath stackYaml @@ -667,7 +672,7 @@ Nothing -> throwM (SolverGiveUp giveUpMsg) Just x -> return x - mOldResolver <- asks (fmap (projectResolver . fst) . configMaybeProject . getConfig) + mOldResolver <- view $ configL.to (fmap (projectResolver . fst) . configMaybeProject) let flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps)) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -5,7 +5,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -- | Build-specific types. @@ -46,37 +45,42 @@ import Control.DeepSeq import Control.Exception -import Data.Binary (Binary) -import Data.Binary.Tagged (HasSemanticVersion, HasStructuralInfo) -import qualified Data.ByteString as S -import Data.Char (isSpace) +import Data.Binary (Binary) +import Data.Binary.Tagged (HasSemanticVersion, + HasStructuralInfo) +import qualified Data.ByteString as S +import Data.Char (isSpace) import Data.Data import Data.Hashable import Data.List.Extra -import qualified Data.Map as Map -import Data.Map.Strict (Map) +import qualified Data.Map as Map +import Data.Map.Strict (Map) import Data.Maybe import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Store.Internal (Store) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Store.Internal (Store) import Data.Store.Version import Data.Store.VersionTagged -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Calendar import Data.Time.Clock +import Data.Version (showVersion) import Distribution.PackageDescription (TestSuiteInterface) -import Distribution.System (Arch) -import qualified Distribution.Text as C -import GHC.Generics (Generic) -import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) -import Path.Extra (toFilePathNoTrailingSep) +import Distribution.System (Arch) +import qualified Distribution.Text as C +import GHC.Generics (Generic) +import Path (Abs, Dir, File, Path, + mkRelDir, parseRelDir, + toFilePath, ()) +import Path.Extra (toFilePathNoTrailingSep) +import Paths_stack as Meta import Prelude import Stack.Constants -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config @@ -86,9 +90,9 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Exit (ExitCode (ExitFailure)) -import System.FilePath (pathSeparator) -import System.Process.Log (showProcessArgDebug) +import System.Exit (ExitCode (ExitFailure)) +import System.FilePath (pathSeparator) +import System.Process.Log (showProcessArgDebug) ---------------------------------------------- -- Exceptions @@ -131,6 +135,7 @@ | SomeTargetsNotBuildable [(PackageName, NamedComponent)] | TestSuiteExeMissing Bool String String String | CabalCopyFailed Bool String + | LocalPackagesPresent [PackageIdentifier] deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -184,7 +189,10 @@ | Set.null noKnown = [] | otherwise = return $ "The following target packages were not found: " ++ - intercalate ", " (map packageNameString $ Set.toList noKnown) + intercalate ", " (map packageNameString $ Set.toList noKnown) ++ + "\nSee https://docs.haskellstack.org/en/v" + <> showVersion Meta.version <> + "/build_command/#target-syntax for details." notInSnapshot' | Map.null notInSnapshot = [] | otherwise = @@ -195,8 +203,8 @@ : "but there's no guarantee that they'll build together)." : "" : map - (\(name, version) -> "- " ++ packageIdentifierString - (PackageIdentifier name version)) + (\(name, version') -> "- " ++ packageIdentifierString + (PackageIdentifier name version')) (Map.toList notInSnapshot) show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat [ ["Test suite failure for package " ++ packageIdentifierString ident] @@ -331,6 +339,9 @@ , "\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 = @@ -356,8 +367,8 @@ deriving (Show,Typeable,Eq,Hashable,Store,NFData) -- | Stored on disk to know whether the files have changed. -data BuildCache = BuildCache - { buildCacheTimes :: !(Map FilePath FileCacheInfo) +newtype BuildCache = BuildCache + { buildCacheTimes :: Map FilePath FileCacheInfo -- ^ Modification times of files. } deriving (Generic, Eq, Show, Data, Typeable) @@ -436,7 +447,7 @@ { planTasks :: !(Map PackageName Task) , planFinals :: !(Map PackageName Task) -- ^ Final actions to be taken (test, benchmark, etc) - , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text)) + , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text)) -- ^ Text is reason we're unregistering, for display only , planInstallExes :: !(Map Text InstallLocation) -- ^ Executables that should be installed after successful building @@ -536,6 +547,8 @@ , let profFlag = "--enable-" <> concat ["executable-" | not newerCabal] <> "profiling" in [ profFlag | boptsExeProfile bopts && isLocal] , ["--enable-split-objs" | boptsSplitObjs bopts] + , ["--disable-library-stripping" | not $ boptsLibStrip bopts || boptsExeStrip bopts] + , ["--disable-executable-stripping" | not (boptsExeStrip bopts) && isLocal] , map (\(name,enabled) -> "-f" <> (if enabled @@ -547,12 +560,12 @@ , map (("--extra-include-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraIncludeDirs config)) , map (("--extra-lib-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraLibDirs config)) , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config) - , ["--ghcjs" | whichCompiler (envConfigCompilerVersion econfig) == Ghcjs] + , ["--ghcjs" | wc == Ghcjs] , ["--exact-configuration" | useExactConf] ] where - wc = whichCompiler (envConfigCompilerVersion econfig) - config = getConfig econfig + wc = view (actualCompilerVersionL.to whichCompiler) econfig + config = view configL econfig bopts = bcoBuildOpts bco -- TODO: instead always enable this when the cabal version is new @@ -560,7 +573,7 @@ -- earlier. Cabal also might do less work then. useExactConf = configAllowNewer config - newerCabal = envConfigCabalVersion econfig >= $(mkVersion "1.22") + newerCabal = view cabalVersionL econfig >= $(mkVersion "1.22") -- Unioning atop defaults is needed so that all flags are specified -- with --exact-configuration. @@ -582,10 +595,10 @@ [ "--constraint=" , packageNameString name , "==" - , versionString version + , versionString version' ] where - PackageIdentifier name version = ident + PackageIdentifier name version' = ident -- | Get set of wanted package names from locals. wantedLocalPackages :: [LocalPackage] -> Set PackageName diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -30,6 +30,9 @@ , parseSnapName , SnapshotHash (..) , trimmedSnapshotHash + , ModuleName (..) + , ModuleInfo (..) + , moduleInfoVC ) where import Control.Applicative @@ -195,6 +198,7 @@ , pcBuildBenchmarks :: Bool , pcFlagOverrides :: Map FlagName Bool , pcEnableLibProfile :: Bool + , pcHide :: Bool } deriving (Show, Eq) instance ToJSON PackageConstraints where @@ -205,6 +209,7 @@ , "build-benchmarks" .= pcBuildBenchmarks , "flags" .= pcFlagOverrides , "library-profiling" .= pcEnableLibProfile + , "hide" .= pcHide ] where addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer @@ -218,6 +223,7 @@ pcFlagOverrides <- o .: "flags" pcMaintainer <- o .:? "maintainer" pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") + pcHide <- o .:? "hide" .!= False return PackageConstraints {..} data TestState = ExpectSuccess @@ -428,7 +434,7 @@ instance NFData MiniBuildPlan miniBuildPlanVC :: VersionConfig MiniBuildPlan -miniBuildPlanVC = storeVersionConfig "mbp-v1" "C8q73RrYq3plf9hDCapjWpnm_yc=" +miniBuildPlanVC = storeVersionConfig "mbp-v2" "C8q73RrYq3plf9hDCapjWpnm_yc=" -- | Information on a single package for the 'MiniBuildPlan'. data MiniPackageInfo = MiniPackageInfo @@ -455,10 +461,24 @@ instance NFData MiniPackageInfo newtype GitSHA1 = GitSHA1 ByteString - deriving (Generic, Show, Eq, NFData, Store, Data, Typeable) + deriving (Generic, Show, Eq, NFData, Store, Data, Typeable, Ord, Hashable) newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString } deriving (Generic, Show, Eq) trimmedSnapshotHash :: SnapshotHash -> ByteString trimmedSnapshotHash = BS.take 12 . unShapshotHash + +newtype ModuleName = ModuleName { unModuleName :: ByteString } + deriving (Show, Eq, Ord, Generic, Store, NFData, Typeable, Data) + +data ModuleInfo = ModuleInfo + { miCorePackages :: !(Set PackageName) + , miModules :: !(Map ModuleName (Set PackageName)) + } + deriving (Show, Eq, Ord, Generic, Typeable, Data) +instance Store ModuleInfo +instance NFData ModuleInfo + +moduleInfoVC :: VersionConfig ModuleInfo +moduleInfoVC = storeVersionConfig "mi-v1" "zyCpzzGXA8fTeBmKEWLa_6kF2_s=" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- 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 #-} @@ -24,20 +27,17 @@ -- * Main configuration types and classes -- ** HasPlatform & HasStackRoot HasPlatform(..) - ,HasStackRoot(..) ,PlatformVariant(..) -- ** Config & HasConfig ,Config(..) ,HasConfig(..) - ,askConfig ,askLatestSnapshotUrl ,explicitSetupDeps ,getMinimalEnvOverride -- ** BuildConfig & HasBuildConfig ,BuildConfig(..) - ,bcRoot - ,bcWorkDir - ,bcWantedCompiler + ,stackYamlL + ,projectRootL ,HasBuildConfig(..) -- ** GHCVariant & HasGHCVariant ,GHCVariant(..) @@ -51,7 +51,6 @@ -- ** EnvConfig & HasEnvConfig ,EnvConfig(..) ,HasEnvConfig(..) - ,getWhichCompiler ,getCompilerPath -- * Details -- ** ApplyGhcOptions @@ -72,6 +71,7 @@ -- ** GlobalOpts & GlobalOptsMonoid ,GlobalOpts(..) ,GlobalOptsMonoid(..) + ,StackYamlLoc(..) ,defaultLogLevel -- ** LoadConfig ,LoadConfig(..) @@ -89,7 +89,9 @@ ,IndexLocation(..) -- Config fields ,configPackageIndex + ,configPackageIndexOld ,configPackageIndexCache + ,configPackageIndexCacheOld ,configPackageIndexGz ,configPackageIndexRoot ,configPackageIndexRepo @@ -130,8 +132,9 @@ ,packageDatabaseLocal ,platformOnlyRelDir ,platformGhcRelDir + ,platformGhcVerOnlyRelDir ,useShaPathOnWindows - ,getWorkDir + ,workDirL -- * Command-specific types -- ** Eval ,EvalOpts(..) @@ -149,6 +152,27 @@ ,DockerEntrypoint(..) ,DockerUser(..) ,module X + -- * Lens helpers + ,wantedCompilerVersionL + ,actualCompilerVersionL + ,buildOptsL + ,globalOptsL + ,buildOptsInstallExesL + ,buildOptsMonoidHaddockL + ,buildOptsMonoidTestsL + ,buildOptsMonoidBenchmarksL + ,buildOptsMonoidInstallExesL + ,buildOptsHaddockL + ,globalOptsBuildOptsMonoidL + ,packageIndicesL + ,packageCachesL + ,stackRootL + ,configUrlsL + ,cabalVersionL + ,whichCompilerL + -- * Lens reexport + ,view + ,to ) where import Control.Applicative @@ -157,7 +181,7 @@ import Control.Monad (liftM, mzero, join) import Control.Monad.Catch (MonadThrow, MonadMask) import Control.Monad.Logger (LogLevel(..), MonadLoggerIO) -import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) +import Control.Monad.Reader (MonadReader, MonadIO, liftIO) import Control.Monad.Trans.Control import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, object, @@ -168,6 +192,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) +import Data.HashMap.Strict (HashMap) import Data.IORef (IORef) import Data.List (stripPrefix) import Data.List.NonEmpty (NonEmpty) @@ -190,13 +215,15 @@ import Distribution.Version (anyVersion) import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +import Lens.Micro (Lens', lens, _1, _2, to, Getting) +import Lens.Micro.Mtl (view) import Network.HTTP.Client (parseRequest) import Options.Applicative (ReadM) import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA import Path import qualified Paths_stack as Meta -import Stack.Types.BuildPlan (MiniBuildPlan(..), SnapName, renderSnapName) +import Stack.Types.BuildPlan (GitSHA1, MiniBuildPlan(..), SnapName, renderSnapName) import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker @@ -218,8 +245,8 @@ import Stack.Types.Config.Build as X #ifdef mingw32_HOST_OS -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Data.ByteString.Base16 as B16 +import Crypto.Hash (hashWith, SHA1(..)) +import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) #endif -- | The top-level Stackage configuration. @@ -333,13 +360,17 @@ ,configAllowDifferentUser :: !Bool -- ^ Allow users other than the stack root owner to use the stack -- installation. - ,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache)))) + ,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache), + HashMap GitSHA1 (PackageIndex, OffsetSize)))) -- ^ In memory cache of hackage index. ,configDumpLogs :: !DumpLogs -- ^ Dump logs of local non-dependencies when doing a build. ,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? @@ -406,6 +437,7 @@ | ExecOptsEmbellished { eoEnvSettings :: !EnvSettings , eoPackages :: ![String] + , eoRtsOptions :: ![String] } deriving (Show) @@ -426,9 +458,15 @@ , 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 @@ -467,13 +505,17 @@ -- | A superset of 'Config' adding information on how to build code. The reason -- for this breakdown is because we will need some of the information from -- 'Config' in order to determine the values here. +-- +-- These are the components which know nothing about local configuration. data BuildConfig = BuildConfig { bcConfig :: !Config , bcResolver :: !LoadedResolver -- ^ How we resolve which dependencies to install given a set of -- packages. , bcWantedMiniBuildPlan :: !MiniBuildPlan - -- ^ Compiler version wanted for this build + -- ^ Build plan wanted for this build + , bcGHCVariant :: !GHCVariant + -- ^ The variant of GHC used to select a GHC bindist. , bcPackageEntries :: ![PackageEntry] -- ^ Local packages , bcExtraDeps :: !(Map PackageName Version) @@ -487,28 +529,23 @@ -- ^ Location of the stack.yaml file. -- -- Note: if the STACK_YAML environment variable is used, this may be - -- different from bcRoot "stack.yaml" + -- different from projectRootL "stack.yaml" + -- + -- FIXME MSS 2016-12-08: is the above comment still true? projectRootL + -- is defined in terms of bcStackYaml , bcFlags :: !PackageFlags -- ^ Per-package flag overrides , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages. - , bcGHCVariant :: !GHCVariant - -- ^ The variant of GHC used to select a GHC bindist. } --- | Directory containing the project's stack.yaml file -bcRoot :: BuildConfig -> Path Abs Dir -bcRoot = parent . bcStackYaml - --- | @"'bcRoot'/.stack-work"@ -bcWorkDir :: (MonadReader env m, HasConfig env) => BuildConfig -> m (Path Abs Dir) -bcWorkDir bconfig = do - workDir <- getWorkDir - return (bcRoot bconfig workDir) +stackYamlL :: HasBuildConfig env => Lens' env (Path Abs File) +stackYamlL = buildConfigL.lens bcStackYaml (\x y -> x { bcStackYaml = y }) -bcWantedCompiler :: BuildConfig -> CompilerVersion -bcWantedCompiler = mbpCompilerVersion . bcWantedMiniBuildPlan +-- | Directory containing the project's stack.yaml file +projectRootL :: HasBuildConfig env => Getting r env (Path Abs Dir) +projectRootL = stackYamlL.to parent -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig @@ -521,22 +558,14 @@ -- depends on as a library and which is displayed when running -- @stack list-dependencies | grep Cabal@ in the stack project. ,envConfigCompilerVersion :: !CompilerVersion + -- ^ The actual version of the compiler to be used, as opposed to + -- 'wantedCompilerL', which provides the version specified by the + -- build plan. ,envConfigCompilerBuild :: !CompilerBuild ,envConfigPackagesRef :: !(IORef (Maybe (Map (Path Abs Dir) TreatLikeExtraDep))) -- ^ Cache for 'getLocalPackages'. } -instance HasBuildConfig EnvConfig where - getBuildConfig = envConfigBuildConfig -instance HasConfig EnvConfig -instance HasPlatform EnvConfig -instance HasGHCVariant EnvConfig -instance HasStackRoot EnvConfig -class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where - getEnvConfig :: r -> EnvConfig -instance HasEnvConfig EnvConfig where - getEnvConfig = id - -- | Value returned by 'Stack.Config.loadConfig'. data LoadConfig m = LoadConfig { lcConfig :: !Config @@ -661,59 +690,6 @@ , "extra-package-dbs" .= projectExtraPackageDBs p ] --- | Class for environment values which have access to the stack root -class HasStackRoot env where - getStackRoot :: env -> Path Abs Dir - default getStackRoot :: HasConfig env => env -> Path Abs Dir - getStackRoot = configStackRoot . getConfig - {-# INLINE getStackRoot #-} - --- | Class for environment values which have a Platform -class HasPlatform env where - getPlatform :: env -> Platform - default getPlatform :: HasConfig env => env -> Platform - getPlatform = configPlatform . getConfig - {-# INLINE getPlatform #-} - getPlatformVariant :: env -> PlatformVariant - default getPlatformVariant :: HasConfig env => env -> PlatformVariant - getPlatformVariant = configPlatformVariant . getConfig - {-# INLINE getPlatformVariant #-} -instance HasPlatform (Platform,PlatformVariant) where - getPlatform (p,_) = p - getPlatformVariant (_,v) = v - --- | Class for environment values which have a GHCVariant -class HasGHCVariant env where - getGHCVariant :: env -> GHCVariant - default getGHCVariant :: HasBuildConfig env => env -> GHCVariant - getGHCVariant = bcGHCVariant . getBuildConfig - {-# INLINE getGHCVariant #-} -instance HasGHCVariant GHCVariant where - getGHCVariant = id - --- | Class for environment values that can provide a 'Config'. -class (HasStackRoot env, HasPlatform env) => HasConfig env where - getConfig :: env -> Config - default getConfig :: HasBuildConfig env => env -> Config - getConfig = bcConfig . getBuildConfig - {-# INLINE getConfig #-} -instance HasStackRoot Config -instance HasPlatform Config -instance HasConfig Config where - getConfig = id - {-# INLINE getConfig #-} - --- | Class for environment values that can provide a 'BuildConfig'. -class HasConfig env => HasBuildConfig env where - getBuildConfig :: env -> BuildConfig -instance HasStackRoot BuildConfig -instance HasPlatform BuildConfig -instance HasGHCVariant BuildConfig -instance HasConfig BuildConfig -instance HasBuildConfig BuildConfig where - getBuildConfig = id - {-# INLINE getBuildConfig #-} - -- | Constraint synonym for constraints satisfied by a 'MiniConfig' -- environment. type StackMiniM r m = @@ -1029,6 +1005,8 @@ | FailedToCloneRepo String | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC | NixRequiresSystemGhc + | NoResolverWhenUsingNoLocalConfig + | InvalidResolverForNoLocalConfig String deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1147,6 +1125,8 @@ , 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 @@ -1169,33 +1149,28 @@ data SuggestSolver = SuggestSolver | Don'tSuggestSolver --- | Helper function to ask the environment and apply getConfig -askConfig :: (MonadReader env m, HasConfig env) => m Config -askConfig = liftM getConfig ask - -- | Get the URL to request the information on the latest snapshots askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text -askLatestSnapshotUrl = asks (urlsLatestSnapshot . configUrls . getConfig) +askLatestSnapshotUrl = view $ configL.to configUrls.to urlsLatestSnapshot -- | Root for a specific package index configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir) configPackageIndexRoot (IndexName name) = do - config <- asks getConfig + root <- view stackRootL dir <- parseRelDir $ S8.unpack name - return (configStackRoot config $(mkRelDir "indices") dir) + return (root $(mkRelDir "indices") dir) -- | Git repo directory for a specific package index, returns 'Nothing' if not -- a Git repo configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir)) configPackageIndexRepo name = do - indices <- asks $ configPackageIndices . getConfig + indices <- view packageIndicesL case filter (\p -> indexName p == name) indices of [index] -> do let murl = - case indexLocation index of - ILGit x -> Just x - ILHttp _ -> Nothing - ILGitHttp x _ -> Just x + case simplifyIndexLocation $ indexLocation index of + SILGit x -> Just x + SILHttp _ _ -> Nothing case murl of Nothing -> return Nothing Just url -> do @@ -1207,17 +1182,27 @@ return $ Just $ suDir repoName _ -> assert False $ return Nothing --- | Location of the 00-index.cache file +-- | Location of the 01-index.cache file configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexCache = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot +configPackageIndexCache = liftM ( $(mkRelFile "01-index.cache")) . configPackageIndexRoot --- | Location of the 00-index.tar file +-- | Location of the 00-index.cache file +configPackageIndexCacheOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) +configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot + +-- | Location of the 01-index.tar file configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndex = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot +configPackageIndex = liftM ( $(mkRelFile "01-index.tar")) . configPackageIndexRoot --- | Location of the 00-index.tar.gz file +-- | Location of the 00-index.tar file. This file is just a copy of +-- the 01-index.tar file, provided for tools which still look for the +-- 00-index.tar file. +configPackageIndexOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) +configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot + +-- | Location of the 01-index.tar.gz file configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexGz = liftM ( $(mkRelFile "00-index.tar.gz")) . configPackageIndexRoot +configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot -- | Location of a package tarball configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File) @@ -1229,15 +1214,15 @@ return (root $(mkRelDir "packages") name ver base) -- | @".stack-work"@ -getWorkDir :: (MonadReader env m, HasConfig env) => m (Path Rel Dir) -getWorkDir = configWorkDir `liftM` asks getConfig +workDirL :: HasConfig env => Lens' env (Path Rel Dir) +workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y }) -- | Per-project work dir getProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir) getProjectWorkDir = do - bc <- asks getBuildConfig - workDir <- getWorkDir - return (bcRoot bc workDir) + root <- view projectRootL + workDir <- view workDirL + return (root workDir) -- | File containing the installed cache, see "Stack.PackageDump" configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File) @@ -1248,38 +1233,38 @@ :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir) platformOnlyRelDir = do - platform <- asks getPlatform - platformVariant <- asks getPlatformVariant + platform <- view platformL + platformVariant <- view platformVariantL parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant) -- | Directory containing snapshots snapshotsDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do - config <- asks getConfig + root <- view stackRootL platform <- platformGhcRelDir - return $ configStackRoot config $(mkRelDir "snapshots") platform + return $ root $(mkRelDir "snapshots") platform -- | Installation root for dependencies installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootDeps = do - config <- asks getConfig + root <- view stackRootL -- TODO: also useShaPathOnWindows here, once #1173 is resolved. psc <- platformSnapAndCompilerRel - return $ configStackRoot config $(mkRelDir "snapshots") psc + return $ root $(mkRelDir "snapshots") psc -- | Installation root for locals installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootLocal = do - bc <- asks getBuildConfig + workDir <- getProjectWorkDir psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel - return $ getProjectWorkDir bc $(mkRelDir "install") psc + return $ workDir $(mkRelDir "install") psc -- | Hoogle directory. hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) hoogleRoot = do - bc <- asks getBuildConfig + workDir <- getProjectWorkDir psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel - return $ getProjectWorkDir bc $(mkRelDir "hoogle") psc + return $ workDir $(mkRelDir "hoogle") psc -- | Get the hoogle database path. hoogleDatabasePath :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs File) @@ -1293,9 +1278,9 @@ :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformSnapAndCompilerRel = do - bc <- asks getBuildConfig + resolver' <- view loadedResolverL platform <- platformGhcRelDir - name <- parseRelDir $ T.unpack $ resolverDirName $ bcResolver bc + name <- parseRelDir $ T.unpack $ resolverDirName resolver' ghc <- compilerVersionDir useShaPathOnWindows (platform name ghc) @@ -1304,10 +1289,10 @@ :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformGhcRelDir = do - envConfig <- asks getEnvConfig + ec <- view envConfigL verOnly <- platformGhcVerOnlyRelDirStr parseRelDir (mconcat [ verOnly - , compilerBuildSuffix (envConfigCompilerBuild envConfig)]) + , compilerBuildSuffix (envConfigCompilerBuild ec)]) -- | Relative directory for the platform and GHC identifier without GHC bindist build platformGhcVerOnlyRelDir @@ -1322,9 +1307,9 @@ :: (MonadReader env m, HasPlatform env, HasGHCVariant env) => m FilePath platformGhcVerOnlyRelDirStr = do - platform <- asks getPlatform - platformVariant <- asks getPlatformVariant - ghcVariant <- asks getGHCVariant + platform <- view platformL + platformVariant <- view platformVariantL + ghcVariant <- view ghcVariantL return $ mconcat [ Distribution.Text.display platform , platformVariantSuffix platformVariant , ghcVariantSuffix ghcVariant ] @@ -1336,14 +1321,14 @@ useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir) useShaPathOnWindows = #ifdef mingw32_HOST_OS - parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath + parseRelDir . S8.unpack . S8.take 8 . Mem.convertToBase Mem.Base16 . hashWith SHA1 . encodeUtf8 . T.pack . toFilePath #else return #endif compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) compilerVersionDir = do - compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) + compilerVersion <- view actualCompilerVersionL parseRelDir $ case compilerVersion of GhcVersion version -> versionString version GhcjsVersion {} -> compilerVersionString compilerVersion @@ -1361,10 +1346,8 @@ return $ root $(mkRelDir "pkgdb") -- | Extra package databases -packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir] -packageDatabaseExtra = do - bc <- asks getBuildConfig - return $ bcExtraPackageDBs bc +packageDatabaseExtra :: (MonadReader env m, HasEnvConfig env) => m [Path Abs Dir] +packageDatabaseExtra = view $ buildConfigL.to bcExtraPackageDBs -- | Directory for holding flag cache information flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) @@ -1377,7 +1360,7 @@ => SnapName -> m (Path Abs File) configMiniBuildPlanCache name = do - root <- asks getStackRoot + root <- view stackRootL platform <- platformGhcVerOnlyRelDir file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" -- Yes, cached plans differ based on platform @@ -1414,8 +1397,8 @@ -- processes like git or ghc getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride getMinimalEnvOverride = do - config <- asks getConfig - liftIO $ configEnvOverride config minimalEnvSettings + config' <- view configL + liftIO $ configEnvOverride config' minimalEnvSettings minimalEnvSettings :: EnvSettings minimalEnvSettings = @@ -1426,9 +1409,6 @@ , esLocaleUtf8 = False } -getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler -getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig) - -- | Get the path for the given compiler ignoring any local binaries. -- -- https://github.com/commercialhaskell/stack/issues/1052 @@ -1437,9 +1417,9 @@ => WhichCompiler -> m (Path Abs File) getCompilerPath wc = do - config <- asks getConfig + config' <- view configL eoWithoutLocals <- liftIO $ - configEnvOverride config minimalEnvSettings { esLocaleUtf8 = True } + configEnvOverride config' minimalEnvSettings { esLocaleUtf8 = True } join (findExecutable eoWithoutLocals (compilerExeName wc)) data ProjectAndConfigMonoid @@ -1700,7 +1680,7 @@ -- | Provide an explicit list of package dependencies when running a custom Setup.hs explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool explicitSetupDeps name = do - m <- asks $ configExplicitSetupDeps . getConfig + m <- view $ configL.to configExplicitSetupDeps return $ -- Yes there are far cleverer ways to write this. I honestly consider -- the explicit pattern matching much easier to parse at a glance. @@ -1712,8 +1692,8 @@ Nothing -> False -- default value -- | Data passed into Docker container for the Docker entrypoint's use -data DockerEntrypoint = DockerEntrypoint - { deUser :: !(Maybe DockerUser) +newtype DockerEntrypoint = DockerEntrypoint + { deUser :: Maybe DockerUser -- ^ UID/GID/etc of host user, if we wish to perform UID/GID switch in container } deriving (Read,Show) @@ -1800,3 +1780,171 @@ mempty = PackageFlags mempty mappend (PackageFlags l) (PackageFlags r) = PackageFlags (Map.unionWith Map.union l r) + +----------------------------------- +-- Lens classes +----------------------------------- + +-- | Class for environment values which have a Platform +class HasPlatform env where + platformL :: Lens' env Platform + default platformL :: HasConfig env => Lens' env Platform + platformL = configL.platformL + {-# INLINE platformL #-} + platformVariantL :: Lens' env PlatformVariant + default platformVariantL :: HasConfig env => Lens' env PlatformVariant + platformVariantL = configL.platformVariantL + {-# INLINE platformVariantL #-} + +-- | Class for environment values which have a GHCVariant +class HasGHCVariant env where + ghcVariantL :: Lens' env GHCVariant + default ghcVariantL :: HasBuildConfig env => Lens' env GHCVariant + ghcVariantL = buildConfigL.ghcVariantL + {-# INLINE ghcVariantL #-} + +-- | Class for environment values that can provide a 'Config'. +class HasPlatform env => HasConfig env where + configL :: Lens' env Config + default configL :: HasBuildConfig env => Lens' env Config + configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) + {-# INLINE configL #-} + +class HasConfig env => HasBuildConfig env where + buildConfigL :: Lens' env BuildConfig + default buildConfigL :: HasEnvConfig env => Lens' env BuildConfig + buildConfigL = envConfigL.lens + envConfigBuildConfig + (\x y -> x { envConfigBuildConfig = y }) + +class (HasBuildConfig env, HasGHCVariant env) => HasEnvConfig env where + envConfigL :: Lens' env EnvConfig + +----------------------------------- +-- Lens instances +----------------------------------- + +instance HasPlatform (Platform,PlatformVariant) where + platformL = _1 + platformVariantL = _2 +instance HasPlatform Config where + platformL = lens configPlatform (\x y -> x { configPlatform = y }) + platformVariantL = lens configPlatformVariant (\x y -> x { configPlatformVariant = y }) +instance HasPlatform BuildConfig +instance HasPlatform EnvConfig + +instance HasGHCVariant GHCVariant where + ghcVariantL = id + {-# INLINE ghcVariantL #-} +instance HasGHCVariant BuildConfig where + ghcVariantL = lens bcGHCVariant (\x y -> x { bcGHCVariant = y }) +instance HasGHCVariant EnvConfig + +instance HasConfig Config where + configL = id + {-# INLINE configL #-} +instance HasConfig BuildConfig where + configL = lens bcConfig (\x y -> x { bcConfig = y }) +instance HasConfig EnvConfig + +instance HasBuildConfig BuildConfig where + buildConfigL = id + {-# INLINE buildConfigL #-} +instance HasBuildConfig EnvConfig + +instance HasEnvConfig EnvConfig where + envConfigL = id + {-# INLINE envConfigL #-} + +----------------------------------- +-- Helper lenses +----------------------------------- + +stackRootL :: HasConfig s => Lens' s (Path Abs Dir) +stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) + +-- | The compiler specified by the @MiniBuildPlan@. This may be +-- different from the actual compiler used! +wantedCompilerVersionL :: HasBuildConfig s => Lens' s CompilerVersion +wantedCompilerVersionL = miniBuildPlanL.lens + mbpCompilerVersion + (\x y -> x { mbpCompilerVersion = y }) + +-- | The version of the compiler which will actually be used. May be +-- different than that specified in the 'MiniBuildPlan' and returned +-- by 'wantedCompilerVersionL'. +actualCompilerVersionL :: HasEnvConfig s => Lens' s CompilerVersion +actualCompilerVersionL = envConfigL.lens + envConfigCompilerVersion + (\x y -> x { envConfigCompilerVersion = y }) + +loadedResolverL :: HasBuildConfig s => Lens' s LoadedResolver +loadedResolverL = buildConfigL.lens + bcResolver + (\x y -> x { bcResolver = y }) + +miniBuildPlanL :: HasBuildConfig s => Lens' s MiniBuildPlan +miniBuildPlanL = buildConfigL.lens + bcWantedMiniBuildPlan + (\x y -> x { bcWantedMiniBuildPlan = y }) + +packageIndicesL :: HasConfig s => Lens' s [PackageIndex] +packageIndicesL = configL.lens + configPackageIndices + (\x y -> x { configPackageIndices = y }) + +buildOptsL :: HasConfig s => Lens' s BuildOpts +buildOptsL = configL.lens + configBuild + (\x y -> x { configBuild = y }) + +buildOptsMonoidHaddockL :: Lens' BuildOptsMonoid (Maybe Bool) +buildOptsMonoidHaddockL = lens (getFirst . buildMonoidHaddock) + (\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t}) + +buildOptsMonoidTestsL :: Lens' BuildOptsMonoid (Maybe Bool) +buildOptsMonoidTestsL = lens (getFirst . buildMonoidTests) + (\buildMonoid t -> buildMonoid {buildMonoidTests = First t}) + +buildOptsMonoidBenchmarksL :: Lens' BuildOptsMonoid (Maybe Bool) +buildOptsMonoidBenchmarksL = lens (getFirst . buildMonoidBenchmarks) + (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t}) + +buildOptsMonoidInstallExesL :: Lens' BuildOptsMonoid (Maybe Bool) +buildOptsMonoidInstallExesL = + lens (getFirst . buildMonoidInstallExes) + (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First t}) + +buildOptsInstallExesL :: Lens' BuildOpts Bool +buildOptsInstallExesL = + lens boptsInstallExes + (\bopts t -> bopts {boptsInstallExes = t}) + +buildOptsHaddockL :: Lens' BuildOpts Bool +buildOptsHaddockL = + lens boptsHaddock + (\bopts t -> bopts {boptsHaddock = t}) + +globalOptsL :: Lens' GlobalOpts ConfigMonoid +globalOptsL = lens globalConfigMonoid (\x y -> x { globalConfigMonoid = y }) + +globalOptsBuildOptsMonoidL :: Lens' GlobalOpts BuildOptsMonoid +globalOptsBuildOptsMonoidL = globalOptsL.lens + configMonoidBuildOpts + (\x y -> x { configMonoidBuildOpts = y }) + +packageCachesL :: HasConfig env => Lens' env + (IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache) + ,HashMap GitSHA1 (PackageIndex, OffsetSize)))) +packageCachesL = configL.lens configPackageCaches (\x y -> x { configPackageCaches = y }) + +configUrlsL :: HasConfig env => Lens' env Urls +configUrlsL = configL.lens configUrls (\x y -> x { configUrls = y }) + +cabalVersionL :: HasEnvConfig env => Lens' env Version +cabalVersionL = envConfigL.lens + envConfigCabalVersion + (\x y -> x { envConfigCabalVersion = y }) + +whichCompilerL :: Getting r CompilerVersion WhichCompiler +whichCompilerL = to whichCompiler diff --git a/src/Stack/Types/Config.hs-boot b/src/Stack/Types/Config.hs-boot --- a/src/Stack/Types/Config.hs-boot +++ b/src/Stack/Types/Config.hs-boot @@ -32,4 +32,6 @@ | FailedToCloneRepo String | ManualGHCVariantSettingsAreIncompatibleWithSystemGHC | NixRequiresSystemGhc + | NoResolverWhenUsingNoLocalConfig + | InvalidResolverForNoLocalConfig String instance Exception ConfigException diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -44,6 +44,8 @@ data BuildOpts = BuildOpts {boptsLibProfile :: !Bool ,boptsExeProfile :: !Bool + ,boptsLibStrip :: !Bool + ,boptsExeStrip :: !Bool ,boptsHaddock :: !Bool -- ^ Build haddocks? ,boptsHaddockOpts :: !HaddockOpts @@ -88,6 +90,8 @@ defaultBuildOpts = BuildOpts { boptsLibProfile = False , boptsExeProfile = False + , boptsLibStrip = True + , boptsExeStrip = True , boptsHaddock = False , boptsHaddockOpts = defaultHaddockOpts , boptsOpenHaddocks = False @@ -147,6 +151,8 @@ data BuildOptsMonoid = BuildOptsMonoid { buildMonoidLibProfile :: !(First Bool) , buildMonoidExeProfile :: !(First Bool) + , buildMonoidLibStrip :: !(First Bool) + , buildMonoidExeStrip :: !(First Bool) , buildMonoidHaddock :: !(First Bool) , buildMonoidHaddockOpts :: !HaddockOptsMonoid , buildMonoidOpenHaddocks :: !(First Bool) @@ -169,6 +175,8 @@ parseJSON = withObjectWarnings "BuildOptsMonoid" (\o -> do buildMonoidLibProfile <- First <$> o ..:? buildMonoidLibProfileArgName buildMonoidExeProfile <-First <$> o ..:? buildMonoidExeProfileArgName + buildMonoidLibStrip <- First <$> o ..:? buildMonoidLibStripArgName + buildMonoidExeStrip <-First <$> o ..:? buildMonoidExeStripArgName buildMonoidHaddock <- First <$> o ..:? buildMonoidHaddockArgName buildMonoidHaddockOpts <- jsonSubWarnings (o ..:? buildMonoidHaddockOptsArgName ..!= mempty) buildMonoidOpenHaddocks <- First <$> o ..:? buildMonoidOpenHaddocksArgName @@ -193,6 +201,12 @@ buildMonoidExeProfileArgName :: Text buildMonoidExeProfileArgName = "executable-profiling" +buildMonoidLibStripArgName :: Text +buildMonoidLibStripArgName = "library-stripping" + +buildMonoidExeStripArgName :: Text +buildMonoidExeStripArgName = "executable-stripping" + buildMonoidHaddockArgName :: Text buildMonoidHaddockArgName = "haddock" @@ -305,12 +319,12 @@ -- | Haddock Options -data HaddockOpts = - HaddockOpts { hoAdditionalArgs :: ![String] -- ^ Arguments passed to haddock program +newtype HaddockOpts = + HaddockOpts { hoAdditionalArgs :: [String] -- ^ Arguments passed to haddock program } deriving (Eq,Show) -data HaddockOptsMonoid = - HaddockOptsMonoid {hoMonoidAdditionalArgs :: ![String] +newtype HaddockOptsMonoid = + HaddockOptsMonoid {hoMonoidAdditionalArgs :: [String] } deriving (Show, Generic) defaultHaddockOpts :: HaddockOpts diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -40,7 +40,7 @@ import Language.Haskell.TH.Syntax -- | A parse fail. -data FlagNameParseFail +newtype FlagNameParseFail = FlagNameParseFail Text deriving (Typeable) instance Exception FlagNameParseFail diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -26,7 +26,7 @@ import Prelude -- Fix AMP warning -- | A parse fail. -data GhcPkgIdParseFail +newtype GhcPkgIdParseFail = GhcPkgIdParseFail Text deriving Typeable instance Show GhcPkgIdParseFail where diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -18,8 +18,8 @@ import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options. -data ImageOpts = ImageOpts - { imgDockers :: ![ImageDockerOpts] +newtype ImageOpts = ImageOpts + { imgDockers :: [ImageDockerOpts] -- ^ One or more stanzas for docker image settings. } deriving (Show) @@ -39,8 +39,8 @@ -- ^ Filenames of executables to add (if Nothing, add them all) } deriving (Show) -data ImageOptsMonoid = ImageOptsMonoid - { imgMonoidDockers :: ![ImageDockerOpts] +newtype ImageOptsMonoid = ImageOptsMonoid + { imgMonoidDockers :: [ImageDockerOpts] } deriving (Show, Generic) instance FromJSON (WithJSONWarnings ImageOptsMonoid) where diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -2,11 +2,19 @@ -- | Internal types to the library. -module Stack.Types.Internal where +module Stack.Types.Internal + ( Env (..) + , HasTerminal (..) + , HasReExec (..) + , Sticky (..) + , HasSticky (..) + , LogOptions (..) + , HasLogOptions (..) + , view + ) where import Control.Concurrent.MVar import Control.Monad.Logger (LogLevel) -import Data.Monoid.Extra import Data.Text (Text) import Lens.Micro import Stack.Types.Config @@ -20,41 +28,42 @@ ,envSticky :: !Sticky } -instance HasStackRoot config => HasStackRoot (Env config) where - getStackRoot = getStackRoot . envConfig +envConfL :: Lens (Env a) (Env b) a b +envConfL = lens envConfig (\x y -> x { envConfig = y }) + instance HasPlatform config => HasPlatform (Env config) where - getPlatform = getPlatform . envConfig - getPlatformVariant = getPlatformVariant . envConfig + platformL = envConfL.platformL + platformVariantL = envConfL.platformVariantL instance HasGHCVariant config => HasGHCVariant (Env config) where - getGHCVariant = getGHCVariant . envConfig + ghcVariantL = envConfL.ghcVariantL instance HasConfig config => HasConfig (Env config) where - getConfig = getConfig . envConfig + configL = envConfL.configL instance HasBuildConfig config => HasBuildConfig (Env config) where - getBuildConfig = getBuildConfig . envConfig + buildConfigL = envConfL.buildConfigL instance HasEnvConfig config => HasEnvConfig (Env config) where - getEnvConfig = getEnvConfig . envConfig + envConfigL = envConfL.envConfigL -class HasTerminal r where - getTerminal :: r -> Bool +class HasTerminal env where + terminalL :: Lens' env Bool instance HasTerminal (Env config) where - getTerminal = envTerminal + terminalL = lens envTerminal (\x y -> x { envTerminal = y }) -class HasReExec r where - getReExec :: r -> Bool +class HasReExec env where + reExecL :: Lens' env Bool instance HasReExec (Env config) where - getReExec = envReExec + reExecL = lens envReExec (\x y -> x { envReExec = y }) newtype Sticky = Sticky { unSticky :: Maybe (MVar (Maybe Text)) } -class HasSticky r where - getSticky :: r -> Sticky +class HasSticky env where + stickyL :: Lens' env Sticky instance HasSticky (Env config) where - getSticky = envSticky + stickyL = lens envSticky (\x y -> x { envSticky = y }) data LogOptions = LogOptions { logUseColor :: Bool @@ -64,63 +73,8 @@ , logVerboseFormat :: Bool } -class HasLogOptions r where - getLogOptions :: r -> LogOptions +class HasLogOptions env where + logOptionsL :: Lens' env LogOptions instance HasLogOptions (Env config) where - getLogOptions = envLogOptions - -envEnvConfig :: Lens' (Env EnvConfig) EnvConfig -envEnvConfig = lens envConfig - (\s t -> s {envConfig = t}) - -buildOptsMonoidHaddock :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidHaddock = lens (getFirst . buildMonoidHaddock) - (\buildMonoid t -> buildMonoid {buildMonoidHaddock = First t}) - -buildOptsMonoidTests :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidTests = lens (getFirst . buildMonoidTests) - (\buildMonoid t -> buildMonoid {buildMonoidTests = First t}) - -buildOptsMonoidBenchmarks :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidBenchmarks = lens (getFirst . buildMonoidBenchmarks) - (\buildMonoid t -> buildMonoid {buildMonoidBenchmarks = First t}) - -buildOptsMonoidInstallExes :: Lens' BuildOptsMonoid (Maybe Bool) -buildOptsMonoidInstallExes = - lens (getFirst . buildMonoidInstallExes) - (\buildMonoid t -> buildMonoid {buildMonoidInstallExes = First t}) - -buildOptsInstallExes :: Lens' BuildOpts Bool -buildOptsInstallExes = - lens boptsInstallExes - (\bopts t -> bopts {boptsInstallExes = t}) - -buildOptsHaddock :: Lens' BuildOpts Bool -buildOptsHaddock = - lens boptsHaddock - (\bopts t -> bopts {boptsHaddock = t}) - -envConfigBuildOpts :: Lens' EnvConfig BuildOpts -envConfigBuildOpts = - lens - (configBuild . bcConfig . envConfigBuildConfig) - (\envCfg bopts -> - envCfg - { envConfigBuildConfig = (envConfigBuildConfig envCfg) - { bcConfig = (bcConfig (envConfigBuildConfig envCfg)) - { configBuild = bopts - } - } - }) - -globalOptsBuildOptsMonoid :: Lens' GlobalOpts BuildOptsMonoid -globalOptsBuildOptsMonoid = - lens - (configMonoidBuildOpts . globalConfigMonoid) - (\globalOpts boptsMonoid -> - globalOpts - { globalConfigMonoid = (globalConfigMonoid globalOpts) - { configMonoidBuildOpts = boptsMonoid - } - }) + logOptionsL = lens envLogOptions (\x y -> x { envLogOptions = y }) diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -102,6 +102,8 @@ ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules? ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple + ,packageSetupDeps :: !(Maybe (Map PackageName VersionRange)) + -- ^ If present: custom-setup dependencies } deriving (Show,Typeable) diff --git a/src/Stack/Types/PackageDump.hs b/src/Stack/Types/PackageDump.hs --- a/src/Stack/Types/PackageDump.hs +++ b/src/Stack/Types/PackageDump.hs @@ -27,9 +27,10 @@ data InstalledCacheEntry = InstalledCacheEntry { installedCacheProfiling :: !Bool , installedCacheHaddock :: !Bool + , installedCacheSymbols :: !Bool , installedCacheIdent :: !PackageIdentifier } deriving (Eq, Generic, Show, Data, Typeable) instance Store InstalledCacheEntry installedCacheVC :: VersionConfig InstalledCacheInner -installedCacheVC = storeVersionConfig "installed-v1" "5yL7Ngpy4YKWDDCTUI6zAJ9UySI=" +installedCacheVC = storeVersionConfig "installed-v1" "GGyaE6qY9FOqeWtozuadKqS7_QM=" diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -13,7 +13,8 @@ , parsePackageIdentifierFromString , packageIdentifierParser , packageIdentifierString - , packageIdentifierText ) + , packageIdentifierText + , toCabalPackageIdentifier ) where import Control.Applicative @@ -27,13 +28,14 @@ import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T +import qualified Distribution.Package as C import GHC.Generics import Prelude hiding (FilePath) import Stack.Types.PackageName import Stack.Types.Version -- | A parse fail. -data PackageIdentifierParseFail +newtype PackageIdentifierParseFail = PackageIdentifierParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where @@ -101,3 +103,9 @@ -- | Get a Text representation of the package identifier; name-ver. packageIdentifierText :: PackageIdentifier -> Text packageIdentifierText = T.pack . packageIdentifierString + +toCabalPackageIdentifier :: PackageIdentifier -> C.PackageIdentifier +toCabalPackageIdentifier x = + C.PackageIdentifier + (toCabalPackageName (packageIdentifierName x)) + (toCabalVersion (packageIdentifierVersion x)) diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -8,21 +8,29 @@ module Stack.Types.PackageIndex ( PackageDownload (..) + , HSPackageDownload (..) , PackageCache (..) , PackageCacheMap (..) + , OffsetSize (..) -- ** PackageIndex, IndexName & IndexLocation , PackageIndex(..) , IndexName(..) , indexNameText , IndexLocation(..) + , SimplifiedIndexLocation (..) + , simplifyIndexLocation + , HttpType (..) + , HackageSecurity (..) ) where import Control.DeepSeq (NFData) import Control.Monad (mzero) import Data.Aeson.Extended import Data.ByteString (ByteString) +import qualified Data.Foldable as F import Data.Hashable (Hashable) import Data.Data (Data, Typeable) +import Data.HashMap.Strict (HashMap) import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map.Strict as Map @@ -33,13 +41,11 @@ import Data.Word (Word64) import GHC.Generics (Generic) import Path +import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.PackageIdentifier data PackageCache = PackageCache - { pcOffset :: !Int64 - -- ^ offset in bytes into the 00-index.tar file for the .cabal file contents - , pcSize :: !Int64 - -- ^ size in bytes of the .cabal file + { pcOffsetSize :: {-# UNPACK #-}!OffsetSize , pcDownload :: !(Maybe PackageDownload) } deriving (Generic, Eq, Show, Data, Typeable) @@ -47,11 +53,26 @@ instance Store PackageCache instance NFData PackageCache -newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache) - deriving (Generic, Store, NFData, Eq, Show, Data, Typeable) +-- | offset in bytes into the 01-index.tar file for the .cabal file +-- contents, and size in bytes of the .cabal file +data OffsetSize = OffsetSize !Int64 !Int64 + deriving (Generic, Eq, Show, Data, Typeable) +instance Store OffsetSize +instance NFData OffsetSize + +data PackageCacheMap = PackageCacheMap + { pcmIdent :: !(Map PackageIdentifier PackageCache) + -- ^ most recent revision of the package + , pcmSHA :: !(HashMap GitSHA1 OffsetSize) + -- ^ lookup via the GitSHA1 of the cabal file contents + } + deriving (Generic, Eq, Show, Data, Typeable) +instance Store PackageCacheMap +instance NFData PackageCacheMap + data PackageDownload = PackageDownload - { pdSHA512 :: !ByteString + { pdSHA256 :: !ByteString , pdUrl :: !ByteString , pdSize :: !Word64 } @@ -59,9 +80,9 @@ instance Store PackageDownload instance NFData PackageDownload instance FromJSON PackageDownload where - parseJSON = withObject "Package" $ \o -> do + parseJSON = withObject "PackageDownload" $ \o -> do hashes <- o .: "package-hashes" - sha512 <- maybe mzero return (Map.lookup ("SHA512" :: Text) hashes) + sha256 <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) locs <- o .: "package-locations" url <- case reverse locs of @@ -69,11 +90,28 @@ x:_ -> return x size <- o .: "package-size" return PackageDownload - { pdSHA512 = encodeUtf8 sha512 + { pdSHA256 = encodeUtf8 sha256 , pdUrl = encodeUtf8 url , pdSize = size } +-- | Hackage Security provides a different JSON format, we'll have our +-- own JSON parser for it. +newtype HSPackageDownload = HSPackageDownload { unHSPackageDownload :: PackageDownload } +instance FromJSON HSPackageDownload where + parseJSON = withObject "HSPackageDownload" $ \o1 -> do + o2 <- o1 .: "signed" + Object o3 <- o2 .: "targets" + Object o4:_ <- return $ F.toList o3 + len <- o4 .: "length" + hashes <- o4 .: "hashes" + sha256 <- hashes .: "sha256" + return $ HSPackageDownload PackageDownload + { pdSHA256 = encodeUtf8 sha256 + , pdSize = len + , pdUrl = "" + } + -- | Unique name for a package index newtype IndexName = IndexName { unIndexName :: ByteString } deriving (Show, Eq, Ord, Hashable, Store) @@ -88,12 +126,37 @@ Left e -> fail $ "Invalid index name: " ++ show e Right _ -> return $ IndexName $ encodeUtf8 t +data HttpType = HTHackageSecurity !HackageSecurity | HTVanilla + deriving (Show, Eq, Ord) + +data HackageSecurity = HackageSecurity + { hsKeyIds :: ![Text] + , hsKeyThreshold :: !Int + } + deriving (Show, Eq, Ord) +instance FromJSON HackageSecurity where + parseJSON = withObject "HackageSecurity" $ \o -> HackageSecurity + <$> o .: "keyids" + <*> o .: "key-threshold" + -- | Location of the package index. This ensures that at least one of Git or -- HTTP is available. -data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text +data IndexLocation + = ILGit !Text + | ILHttp !Text !HttpType + | ILGitHttp !Text !Text !HttpType deriving (Show, Eq, Ord) +-- | Simplified 'IndexLocation', which will either be a Git repo or HTTP URL. +data SimplifiedIndexLocation = SILGit !Text | SILHttp !Text !HttpType + deriving (Show, Eq, Ord) +simplifyIndexLocation :: IndexLocation -> SimplifiedIndexLocation +simplifyIndexLocation (ILGit t) = SILGit t +simplifyIndexLocation (ILHttp t ht) = SILHttp t ht +-- Prefer HTTP over Git +simplifyIndexLocation (ILGitHttp _ t ht) = SILHttp t ht + -- | Information on a single package index data PackageIndex = PackageIndex { indexName :: !IndexName @@ -113,14 +176,16 @@ prefix <- o ..: "download-prefix" mgit <- o ..:? "git" mhttp <- o ..:? "http" + mhackageSecurity <- o ..:? "hackage-security" + let httpType = maybe HTVanilla HTHackageSecurity mhackageSecurity loc <- case (mgit, mhttp) of (Nothing, Nothing) -> fail $ "Must provide either Git or HTTP URL for " ++ T.unpack (indexNameText name) (Just git, Nothing) -> return $ ILGit git - (Nothing, Just http) -> return $ ILHttp http - (Just git, Just http) -> return $ ILGitHttp git http + (Nothing, Just http) -> return $ ILHttp http httpType + (Just git, Just http) -> return $ ILGitHttp git http httpType gpgVerify <- o ..:? "gpg-verify" ..!= False reqHashes <- o ..:? "require-hashes" ..!= False return PackageIndex diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -138,10 +138,10 @@ runInnerStackT :: (HasEnv r, MonadReader r m, MonadIO m) => config -> StackT config IO a -> m a runInnerStackT config inner = do - reExec <- asks getReExec - logOptions <- asks getLogOptions - terminal <- asks getTerminal - sticky <- asks getSticky + reExec <- view reExecL + logOptions <- view logOptionsL + terminal <- view terminalL + sticky <- view stickyL liftIO $ runReaderT (unStackT inner) Env { envConfig = config , envReExec = reExec @@ -163,8 +163,8 @@ :: (HasEnv r, ToLogStr msg, MonadReader r m) => m (Loc -> LogSource -> LogLevel -> msg -> IO ()) getStickyLoggerFunc = do - sticky <- asks getSticky - lo <- asks getLogOptions + sticky <- view stickyL + lo <- view logOptionsL return $ stickyLoggerFuncImpl sticky lo stickyLoggerFuncImpl @@ -184,8 +184,7 @@ LevelOther "sticky" -> LevelInfo _ -> level) msg - Just ref -> do - sticky <- takeMVar ref + Just ref -> modifyMVar_ ref $ \sticky -> do let backSpaceChar = '\8' repeating = S8.replicate (maybe 0 T.length sticky) clear = S8.hPutStr out @@ -198,31 +197,29 @@ | logUseUnicode lo = msgTextRaw | otherwise = T.map replaceUnicode msgTextRaw - newState <- - case level of - LevelOther "sticky-done" -> do - clear - T.hPutStrLn out msgText - hFlush out - return Nothing - LevelOther "sticky" -> do + case level of + LevelOther "sticky-done" -> do + clear + T.hPutStrLn out msgText + hFlush out + return Nothing + LevelOther "sticky" -> do + clear + T.hPutStr out msgText + hFlush out + return (Just msgText) + _ + | level >= logMinLevel lo -> do clear - T.hPutStr out msgText - hFlush out - return (Just msgText) - _ - | level >= logMinLevel lo -> do - clear - loggerFunc lo out loc src level $ toLogStr msgText - case sticky of - Nothing -> - return Nothing - Just line -> do - T.hPutStr out line >> hFlush out - return sticky - | otherwise -> - return sticky - putMVar ref newState + loggerFunc lo out loc src level $ toLogStr msgText + case sticky of + Nothing -> + return Nothing + Just line -> do + T.hPutStr out line >> hFlush out + return sticky + | otherwise -> + return sticky where out = stderr msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -57,7 +57,7 @@ import Text.PrettyPrint (render) -- | A parse fail. -data VersionParseFail = +newtype VersionParseFail = VersionParseFail Text deriving (Typeable) instance Exception VersionParseFail diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -34,7 +34,6 @@ import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config -import Stack.Types.Internal import Stack.Types.Resolver import Stack.Types.StackT import System.Exit (ExitCode (ExitSuccess)) @@ -89,8 +88,8 @@ , _boGithubRepo :: !(Maybe String) } deriving Show -data SourceOpts = SourceOpts - { _soRepo :: !(Maybe String) +newtype SourceOpts = SourceOpts + { _soRepo :: Maybe String } deriving Show @@ -114,6 +113,8 @@ (Nothing, Nothing) -> error "You must allow either binary or source upgrade paths" (Just bo, Nothing) -> binary bo (Nothing, Just so) -> source so + -- See #2977 - if --git or --git-repo is specified, do source upgrade. + (_, Just so@(SourceOpts (Just _))) -> source so (Just bo, Just so) -> binary bo `catchAny` \e -> do $logWarn "Exception occured when trying to perform binary upgrade:" $logWarn $ T.pack $ show e @@ -167,7 +168,7 @@ $logInfo "Newer version detected, downloading" return True when toUpgrade $ do - config <- askConfig + config <- view configL downloadStackExe platforms0 archiveInfo (configLocalBin config) $ \tmpFile -> do -- Sanity check! ec <- rawSystem (toFilePath tmpFile) ["--version"] @@ -209,7 +210,7 @@ return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices menv - caches <- getPackageCaches + (caches, _gitShaCaches) <- getPackageCaches let latest = Map.fromListWith max $ map toTuple $ Map.keys @@ -238,12 +239,12 @@ 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 " <> - T.pack (toFilePath (configLocalPrograms (getConfig bconfig))) - runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig1) $ + T.pack (toFilePath (configLocalPrograms (view configL bconfig))) + runInnerStackT (set (buildOptsL.buildOptsInstallExesL) True envConfig1) $ build (const $ return ()) Nothing defaultBuildOptsCLI { boptsCLITargets = ["stack"] } diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -248,8 +248,8 @@ -- Typically, you want to use this with 'upload'. -- -- Since 0.1.0.0 -data Uploader = Uploader - { upload_ :: !(String -> L.ByteString -> IO ()) +newtype Uploader = Uploader + { upload_ :: String -> L.ByteString -> IO () } -- | Upload a single tarball with the given @Uploader@. diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -423,7 +423,7 @@ mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) -data PathException = PathsInvalidInPath [FilePath] +newtype PathException = PathsInvalidInPath [FilePath] deriving Typeable instance Exception PathException diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -18,7 +19,7 @@ import Control.Monad hiding (mapM, forM) import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (asks, local) +import Control.Monad.Reader (local) import Control.Monad.Trans.Either (EitherT) import Control.Monad.Writer.Lazy (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) @@ -54,6 +55,7 @@ import qualified Paths_stack as Meta import Prelude hiding (pi, mapM) import Stack.Build +import Stack.BuildPlan import Stack.Clean (CleanOpts, clean) import Stack.Config import Stack.ConfigCmd as ConfigCmd @@ -82,11 +84,13 @@ import Stack.Options.HpcReportParser import Stack.Options.NewParser import Stack.Options.NixParser +import Stack.Options.ScriptParser import Stack.Options.SolverParser import Stack.Options.Utils import qualified Stack.PackageIndex import qualified Stack.Path import Stack.Runners +import Stack.Script import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball') import Stack.SetupCmd import qualified Stack.Sig as Sig @@ -94,7 +98,8 @@ import Stack.Types.Version import Stack.Types.Config import Stack.Types.Compiler -import Stack.Types.Internal +import Stack.Types.Resolver +import Stack.Types.Nix import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload @@ -319,13 +324,14 @@ execCmd (execOptsParser $ Just ExecGhc) addCommand' "hoogle" - "Run hoogle in the context of the current Stack config" + ("Run hoogle, the Haskell API search engine. Use 'stack exec' syntax " ++ + "to pass Hoogle arguments, e.g. stack hoogle -- --count=20") hoogleCmd ((,,) <$> many (strArgument (metavar "ARG")) <*> boolFlags True "setup" - "If needed: Install hoogle, build haddocks, generate a hoogle database" + "If needed: install hoogle, build haddocks and generate a hoogle database" idm <*> switch (long "rebuild" <> @@ -353,6 +359,10 @@ "Run runghc (alias for 'runghc')" execCmd (execOptsParser $ Just ExecRunGhc) + addCommand' "script" + "Run a Stack Script" + scriptCmd + scriptOptsParser unless isInterpreter (do addCommand' "eval" @@ -465,7 +475,8 @@ extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*> extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*> globalOptsParser kind (if isInterpreter - then Just $ LevelOther "silent" + -- Silent except when errors occur - see #2879 + then Just LevelError else Nothing) where hide = kind /= OuterGlobalOpts @@ -563,6 +574,8 @@ setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = do lc <- loadConfigWithOpts go + when (scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do + throwIO UpgradeCabalUnusable withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc runStackTGlobal (lcConfig lc) go $ @@ -577,11 +590,11 @@ Just v -> return (v, MatchMinor, Nothing) Nothing -> do bc <- lcLoadBuildConfig lc globalCompiler - return ( bcWantedCompiler bc + return ( view wantedCompilerVersionL bc , configCompilerCheck (lcConfig lc) - , Just $ bcStackYaml bc + , Just $ view stackYamlL bc ) - miniConfig <- loadMiniConfig (lcConfig lc) + let miniConfig = loadMiniConfig (lcConfig lc) runStackTGlobal miniConfig go $ setup sco wantedCompiler compilerCheck mstack ) @@ -608,10 +621,10 @@ Stack.Build.build setLocalFiles lk opts -- Read the build command from the CLI and enable it to run go' = case boptsCLICommand opts of - Test -> set (globalOptsBuildOptsMonoid.buildOptsMonoidTests) (Just True) go - Haddock -> set (globalOptsBuildOptsMonoid.buildOptsMonoidHaddock) (Just True) go - Bench -> set (globalOptsBuildOptsMonoid.buildOptsMonoidBenchmarks) (Just True) go - Install -> set (globalOptsBuildOptsMonoid.buildOptsMonoidInstallExes) (Just True) go + Test -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) go + Haddock -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidHaddockL) (Just True) go + Bench -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) go + Install -> set (globalOptsBuildOptsMonoidL.buildOptsMonoidInstallExesL) (Just True) go Build -> go -- Default case is just Build uninstallCmd :: [String] -> GlobalOpts -> IO () @@ -624,7 +637,19 @@ unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go = withConfigAndLock go $ do menv <- getMinimalEnvOverride - Stack.Fetch.unpackPackages menv "." names + mMiniBuildPlan <- + case globalResolver go of + Nothing -> return Nothing + Just ar -> fmap Just $ do + r <- makeConcreteResolver ar + case r of + ResolverSnapshot snapName -> do + config <- view configL + let miniConfig = loadMiniConfig config + runInnerStackT miniConfig (loadMiniBuildPlan snapName) + ResolverCompiler _ -> error "unpack does not work with compiler resolvers" + ResolverCustom _ _ -> error "unpack does not work with custom resolvers" + Stack.Fetch.unpackPackages menv mMiniBuildPlan "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () @@ -658,7 +683,7 @@ show invalid let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader getUploader = do - config <- asks getConfig + config <- view configL liftIO $ Upload.mkUploader config Upload.defaultUploadSettings withBuildConfigAndLock go $ \_ -> do uploader <- getUploader @@ -714,9 +739,9 @@ case eoExtra of ExecOptsPlain -> do (cmd, args) <- case (eoCmd, eoArgs) of - (ExecCmd cmd, args) -> return (cmd, args) - (ExecGhc, args) -> return ("ghc", args) - (ExecRunGhc, args) -> return ("runghc", args) + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> return ("ghc", args) + (ExecRunGhc, args) -> return ("runghc", args) lc <- liftIO $ loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc @@ -726,7 +751,7 @@ -- Unlock before transferring control away, whether using docker or not: (Just $ munlockFile lk) (runStackTGlobal (lcConfig lc) go $ do - config <- asks getConfig + config <- view configL menv <- liftIO $ configEnvOverride config plainEnvSettings Nix.reexecWithOptionalShell (lcProjectRoot lc) @@ -736,24 +761,28 @@ Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> - withBuildConfigAndLock go $ \lk -> do - let targets = concatMap words eoPackages - unless (null targets) $ - Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI - { boptsCLITargets = map T.pack targets - } + withBuildConfigAndLock go $ \lk -> do + let targets = concatMap words eoPackages + unless (null targets) $ + Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + { boptsCLITargets = map T.pack targets + } - config <- asks getConfig - menv <- liftIO $ configEnvOverride config eoEnvSettings - (cmd, args) <- case (eoCmd, eoArgs) of - (ExecCmd cmd, args) -> return (cmd, args) - (ExecGhc, args) -> getGhcCmd "" menv eoPackages args + config <- view configL + menv <- liftIO $ configEnvOverride config eoEnvSettings + -- Add RTS options to arguments + let argsWithRts args = if null eoRtsOptions + then args :: [String] + else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"] + (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of + (ExecCmd cmd, args) -> return (cmd, args) + (ExecGhc, args) -> getGhcCmd "" menv eoPackages args -- NOTE: this won't currently work for GHCJS, because it doesn't have -- a runghcjs binary. It probably will someday, though. - (ExecRunGhc, args) -> - getGhcCmd "run" menv eoPackages args - munlockFile lk -- Unlock before transferring control away. - exec menv cmd args + (ExecRunGhc, args) -> + getGhcCmd "run" menv eoPackages args + munlockFile lk -- Unlock before transferring control away. + exec menv cmd args where -- return the package-id of the first package in GHC_PACKAGE_PATH getPkgId menv wc name = do @@ -768,9 +797,10 @@ return $ map ("-package-id=" ++) ids getGhcCmd prefix menv pkgs args = do - wc <- getWhichCompiler + wc <- view $ actualCompilerVersionL.whichCompilerL pkgopts <- getPkgOpts menv wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) + -- | Evaluate some haskell code inline. evalCmd :: EvalOpts -> GlobalOpts -> IO () @@ -787,13 +817,13 @@ ghciCmd ghciOpts go@GlobalOpts{..} = withBuildConfigAndLock go $ \lk -> do munlockFile lk -- Don't hold the lock while in the GHCI. - bopts <- asks (configBuild . getConfig) + bopts <- view buildOptsL -- override env so running of tests and benchmarks is disabled let boptsLocal = bopts { boptsTestOpts = (boptsTestOpts bopts) { toDisableRun = True } , boptsBenchmarkOpts = (boptsBenchmarkOpts bopts) { beoDisableRun = True } } - local (set (envEnvConfig.envConfigBuildOpts) boptsLocal) + local (set buildOptsL boptsLocal) (ghci ghciOpts) -- | List packages in the project. @@ -838,7 +868,7 @@ cfgSetCmd co go@GlobalOpts{..} = withMiniConfigAndLock go - (cfgCmdSet co) + (cfgCmdSet go co) imgDockerCmd :: (Bool, [Text]) -> GlobalOpts -> IO () imgDockerCmd (rebuild,images) go@GlobalOpts{..} = do @@ -892,8 +922,8 @@ withBuildConfigDot opts go f = withBuildConfig go' f where go' = - (if dotTestTargets opts then set (globalOptsBuildOptsMonoid.buildOptsMonoidTests) (Just True) else id) $ - (if dotBenchTargets opts then set (globalOptsBuildOptsMonoid.buildOptsMonoidBenchmarks) (Just True) else id) + (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $ + (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) go -- | Query build information @@ -905,6 +935,7 @@ hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts data MainException = InvalidReExecVersion String String + | UpgradeCabalUnusable deriving (Typeable) instance Exception MainException instance Show MainException where @@ -915,3 +946,4 @@ , expected , "; found: " , actual] + show UpgradeCabalUnusable = "--upgrade-cabal cannot be used when nix is activated" diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -1,15 +1,11 @@ -{-# LANGUAGE RecordWildCards #-} module Network.HTTP.Download.VerifiedSpec where import Control.Applicative -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Logger (LoggingT, runStdoutLoggingT) -import Control.Monad.Trans.Reader +import Control.Monad.Logger (runStdoutLoggingT) import Control.Retry (limitRetries) import Crypto.Hash import Data.Maybe import Network.HTTP.Client.Conduit -import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Download.Verified import Path import Path.IO @@ -65,76 +61,61 @@ isWrongDigest WrongDigest{} = True isWrongDigest _ = False -data T = T - { manager :: Manager - } - -runWith :: MonadIO m => Manager -> ReaderT Manager (LoggingT m) r -> m r -runWith manager = runStdoutLoggingT . flip runReaderT manager - -setup :: IO T -setup = do - manager <- getGlobalManager - return T{..} - -teardown :: T -> IO () -teardown _ = return () - spec :: Spec -spec = beforeAll setup $ afterAll teardown $ do +spec = do let exampleProgressHook _ = return () describe "verifiedDownload" $ do -- Preconditions: -- * the exampleReq server is running -- * the test runner has working internet access to it - it "downloads the file correctly" $ \T{..} -> withTempDir' $ \dir -> do + it "downloads the file correctly" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir doesFileExist examplePath `shouldReturn` False - let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True - it "is idempotent, and doesn't redownload unnecessarily" $ \T{..} -> withTempDir' $ \dir -> do + it "is idempotent, and doesn't redownload unnecessarily" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir doesFileExist examplePath `shouldReturn` False - let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True go `shouldReturn` False doesFileExist examplePath `shouldReturn` True -- https://github.com/commercialhaskell/stack/issues/372 - it "does redownload when the destination file is wrong" $ \T{..} -> withTempDir' $ \dir -> do + it "does redownload when the destination file is wrong" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir let exampleFilePath = toFilePath examplePath writeFile exampleFilePath exampleWrongContent doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldReturn` exampleWrongContent - let go = runWith manager $ verifiedDownload exampleReq examplePath exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload exampleReq examplePath exampleProgressHook go `shouldReturn` True doesFileExist examplePath `shouldReturn` True readFile exampleFilePath `shouldNotReturn` exampleWrongContent - it "rejects incorrect content length" $ \T{..} -> withTempDir' $ \dir -> do + it "rejects incorrect content length" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir let wrongContentLengthReq = exampleReq { drLengthCheck = Just exampleWrongContentLength } - let go = runWith manager $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload wrongContentLengthReq examplePath exampleProgressHook go `shouldThrow` isWrongContentLength doesFileExist examplePath `shouldReturn` False - it "rejects incorrect digest" $ \T{..} -> withTempDir' $ \dir -> do + it "rejects incorrect digest" $ withTempDir' $ \dir -> do examplePath <- getExamplePath dir let wrongHashCheck = exampleHashCheck { hashCheckHexDigest = exampleWrongDigest } let wrongDigestReq = exampleReq { drHashChecks = [wrongHashCheck] } - let go = runWith manager $ verifiedDownload wrongDigestReq examplePath exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload wrongDigestReq examplePath exampleProgressHook go `shouldThrow` isWrongDigest doesFileExist examplePath `shouldReturn` False -- https://github.com/commercialhaskell/stack/issues/240 - it "can download hackage tarballs" $ \T{..} -> withTempDir' $ \dir -> do + it "can download hackage tarballs" $ withTempDir' $ \dir -> do dest <- (dir ) <$> parseRelFile "acme-missiles-0.3.tar.gz" let req = parseRequest_ "http://hackage.haskell.org/package/acme-missiles-0.3/acme-missiles-0.3.tar.gz" let dReq = DownloadRequest @@ -143,7 +124,7 @@ , drLengthCheck = Nothing , drRetryPolicy = limitRetries 1 } - let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook + let go = runStdoutLoggingT $ verifiedDownload dReq dest exampleProgressHook doesFileExist dest `shouldReturn` False go `shouldReturn` True doesFileExist dest `shouldReturn` True diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -33,7 +33,7 @@ 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 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -80,7 +80,7 @@ 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 @@ -121,9 +121,8 @@ createDirectory childDir setCurrentDirectory childDir LoadConfig{..} <- loadConfig' - bc@BuildConfig{..} <- loadBuildConfigRest - (lcLoadBuildConfig Nothing) - bcRoot bc `shouldBe` parentDir + bc <- loadBuildConfigRest (lcLoadBuildConfig Nothing) + view projectRootL bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ inTempDir $ do withSystemTempDir "config-is-here" $ \dir -> do diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -221,6 +221,7 @@ , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True , packageSimpleType = True + , packageSetupDeps = Nothing } } ] @@ -255,6 +256,7 @@ , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True , packageSimpleType = True + , packageSetupDeps = Nothing } } , GhciPkgInfo @@ -285,6 +287,7 @@ , packageOpts = GetPackageOpts undefined , packageHasExposedModules = True , packageSimpleType = True + , packageSetupDeps = Nothing } } ] diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -5,13 +5,16 @@ import Control.Exception import Control.Monad.Logger +import Data.Maybe import Data.Monoid +import Options.Applicative import Path import Prelude -- to remove the warning about Data.Monoid being redundant on GHC 7.10 import Stack.Config +import Stack.Options.NixParser import Stack.Config.Nix -import Stack.Types.Config import Stack.Types.Compiler +import Stack.Types.Config import Stack.Types.Nix import Stack.Types.StackT import Stack.Types.Version @@ -20,8 +23,8 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -sampleConfig :: String -sampleConfig = +sampleConfigNixEnabled :: String +sampleConfigNixEnabled = "resolver: lts-2.10\n" ++ "packages: ['.']\n" ++ "system-ghc: true\n" ++ @@ -29,6 +32,13 @@ " enable: True\n" ++ " packages: [glpk]" +sampleConfigNixDisabled :: String +sampleConfigNixDisabled = + "resolver: lts-2.10\n" ++ + "packages: ['.']\n" ++ + "nix:\n" ++ + " enable: False" + stackDotYaml :: Path Rel File stackDotYaml = $(mkRelFile "stack.yaml") @@ -37,22 +47,61 @@ spec :: Spec spec = beforeAll setup $ do - let loadConfig' = runStackT () LevelDebug True False ColorAuto False (loadConfig mempty Nothing Nothing) - inTempDir action = do + let loadConfig' cmdLineArgs = runStackT () LevelDebug True False ColorAuto False (loadConfig cmdLineArgs Nothing SYLDefault) + inTempDir test = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_ConfigSpec" $ \tempDir -> do let enterDir = setCurrentDirectory tempDir exitDir = setCurrentDirectory currentDirectory - bracket_ enterDir exitDir action - describe "nix" $ do - it "sees that the nix shell is enabled" $ inTempDir $ do - writeFile (toFilePath stackDotYaml) sampleConfig - lc <- loadConfig' - nixEnable (configNix $ lcConfig lc) `shouldBe` True - it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ - inTempDir $ do - writeFile (toFilePath stackDotYaml) sampleConfig - lc <- loadConfig' + bracket_ enterDir exitDir test + withStackDotYaml config test = inTempDir $ do + writeFile (toFilePath stackDotYaml) config + test + parseNixOpts cmdLineOpts = fromJust $ getParseResult $ execParserPure + defaultPrefs + (info (nixOptsParser False) mempty) + cmdLineOpts + parseOpts cmdLineOpts = mempty { configMonoidNixOpts = parseNixOpts cmdLineOpts } + describe "nix disabled in config file" $ + around_ (withStackDotYaml sampleConfigNixDisabled) $ do + it "sees that the nix shell is not enabled" $ do + lc <- loadConfig' mempty + nixEnable (configNix $ lcConfig lc) `shouldBe` False + describe "--nix given on command line" $ + it "sees that the nix shell is enabled" $ do + lc <- loadConfig' (parseOpts ["--nix"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` True + describe "--nix-pure given on command line" $ + it "sees that the nix shell is enabled" $ do + lc <- loadConfig' (parseOpts ["--nix-pure"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` True + describe "--no-nix given on command line" $ + it "sees that the nix shell is not enabled" $ do + lc <- loadConfig' (parseOpts ["--no-nix"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` False + describe "--no-nix-pure given on command line" $ + it "sees that the nix shell is not enabled" $ do + lc <- loadConfig' (parseOpts ["--no-nix-pure"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` False + describe "nix enabled in config file" $ + around_ (withStackDotYaml sampleConfigNixEnabled) $ do + it "sees that the nix shell is enabled" $ do + lc <- loadConfig' mempty + nixEnable (configNix $ lcConfig lc) `shouldBe` True + describe "--no-nix given on command line" $ + it "sees that the nix shell is not enabled" $ do + lc <- loadConfig' (parseOpts ["--no-nix"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` False + describe "--nix-pure given on command line" $ + it "sees that the nix shell is enabled" $ do + lc <- loadConfig' (parseOpts ["--nix-pure"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` True + describe "--no-nix-pure given on command line" $ + it "sees that the nix shell is enabled" $ do + lc <- loadConfig' (parseOpts ["--no-nix-pure"]) + nixEnable (configNix $ lcConfig lc) `shouldBe` True + it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ do + lc <- loadConfig' mempty nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"] v <- parseVersion "7.10.3" nixCompiler (GhcVersion v) `shouldBe` "haskell.compiler.ghc7103" diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -91,6 +91,7 @@ , dpHaddockHtml = Just "/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0" , dpProfiling = () , dpHaddock = () + , dpSymbols = () , dpIsExposed = False } @@ -129,6 +130,7 @@ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = () + , dpSymbols = () , dpIsExposed = False } it "ghc 7.8.4 (osx)" $ do @@ -164,6 +166,7 @@ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = () + , dpSymbols = () , dpIsExposed = True } it "ghc HEAD" $ do @@ -193,6 +196,7 @@ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = () + , dpSymbols = () , dpIsExposed = True } @@ -205,6 +209,7 @@ $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache + =$ fakeAddSymbols =$ CL.sinkNull it "sinkMatching" $ do @@ -215,7 +220,8 @@ $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache - =$ sinkMatching False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) + =$ fakeAddSymbols + =$ sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) case Map.lookup $(mkPackageName "base") m of Nothing -> error "base not present" Just _ -> return () @@ -262,3 +268,7 @@ case Map.lookup ident depMap of Nothing -> error "checkDepsPresent: missing in depMap" Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds + +-- addSymbols can't be reasonably tested like this +fakeAddSymbols :: Monad m => Conduit (DumpPackage a b c) m (DumpPackage a b Bool) +fakeAddSymbols = CL.map (\dp -> dp { dpSymbols = False }) diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -10,6 +10,8 @@ import Control.Applicative import qualified Data.ByteString as BS import Data.Containers (mapFromList, setFromList) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) import Data.Int import Data.Map (Map) import Data.Sequences (fromList) @@ -32,6 +34,9 @@ -- smallcheck. instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where + series = fmap mapFromList series + +instance (Monad m, Serial m k, Serial m a, Eq k, Hashable k) => Serial m (HashMap k a) where series = fmap mapFromList series instance Monad m => Serial m Text where diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,5 +1,5 @@ name: stack -version: 1.3.2 +version: 1.4.0 cabal-version: >=1.10 build-type: Custom license: BSD3 @@ -136,6 +136,7 @@ Stack.Options.NixParser Stack.Options.PackageParser Stack.Options.ResolverParser + Stack.Options.ScriptParser Stack.Options.SolverParser Stack.Options.TestParser Stack.Options.Utils @@ -145,6 +146,7 @@ Stack.Path Stack.PrettyPrint Stack.Runners + Stack.Script Stack.SDist Stack.Setup Stack.Setup.Installed @@ -184,27 +186,25 @@ System.Process.Read System.Process.Run build-depends: - Cabal >=1.18.1.5 && <1.25, - aeson ==1.0.*, + Cabal ==1.24.*, + aeson >=1.0 && <1.2, ansi-terminal >=0.6.2.3 && <0.7, async >=2.0.2 && <2.2, attoparsec >=0.12.1.5 && <0.14, - base >=4.7 && <5, + base >=4.8 && <5, base-compat >=0.6 && <0.10, - base16-bytestring >=0.1.1.6 && <0.2, base64-bytestring >=1.0.0.1 && <1.1, binary >=0.7 && <0.9, binary-tagged >=0.1.1 && <0.2, blaze-builder >=0.4.0.2 && <0.5, - byteable >=0.1.1 && <0.2, bytestring >=0.10.4.0 && <0.11, clock >=0.7.2 && <0.8, conduit >=1.2.8 && <1.3, - conduit-extra >=1.1.7.1 && <1.2, + conduit-extra >=1.1.14 && <1.2, containers >=0.5.5.1 && <0.6, - cryptohash >=0.11.6 && <0.12, - cryptohash-conduit >=0.1.1 && <0.2, - directory >=1.2.1.0 && <1.3, + cryptonite ==0.19.*, + cryptonite-conduit ==0.1.*, + directory >=1.2.1.0 && <1.4, either >=4.4.1.1 && <4.5, errors >=2.1.2 && <2.2, exceptions >=0.8.0.2 && <0.9, @@ -214,20 +214,24 @@ filepath >=1.3.0.2 && <1.5, fsnotify >=0.2.1 && <0.3, generic-deriving >=1.10.5 && <1.12, + hackage-security >=0.5.2.2 && <0.6, hashable >=1.2.3.2 && <1.3, hit >=0.6.3 && <0.7, hpc >=0.6.0.2 && <0.7, http-client >=0.5.3.3 && <0.6, - http-client-tls >=0.3.3 && <0.4, + http-client-tls >=0.3.4 && <0.4, http-conduit >=2.2.3 && <2.3, http-types >=0.8.6 && <0.10, lifted-async >=0.9.0 && <0.10, lifted-base >=0.2.3.8 && <0.3, + memory ==0.13.*, microlens >=0.3.0.0 && <0.5, + microlens-mtl >=0.1.10.0 && <0.2, monad-control >=1.0.1.0 && <1.1, monad-logger >=0.3.13.1 && <0.4, monad-unlift >=0.2.0 && <0.3, mtl >=2.1.3.1 && <2.3, + network-uri >=2.6.1.0 && <2.7, open-browser >=0.2.1 && <0.3, optparse-applicative ==0.13.*, path >=0.5.8 && <0.6, @@ -256,10 +260,10 @@ tls >=1.3.8 && <1.4, transformers >=0.3.0.0 && <0.6, transformers-base >=0.4.4 && <0.5, - unicode-transforms >=0.1 && <0.3, + unicode-transforms >=0.1 && <0.4, unix-compat >=0.4.1.4 && <0.5, unordered-containers >=0.2.5.1 && <0.3, - vector >=0.10.12.3 && <0.12, + vector >=0.10.12.3 && <0.13, vector-binary-instances >=0.2.3.2 && <0.3, yaml >=0.8.20 && <0.9, zlib >=0.5.4.2 && <0.7, @@ -267,12 +271,14 @@ hastache >=0.6.1 && <0.7, project-template ==0.2.*, zip-archive >=0.2.3.7 && <0.4, - hpack >=0.14.0 && <0.16, + hpack >=0.17.0 && <0.18, store >=0.2.1.0 && <0.4, annotated-wl-pprint >=0.7.0 && <0.8, file-embed >=0.0.10 && <0.1 default-language: Haskell2010 hs-source-dirs: src/ + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities executable stack @@ -298,12 +304,13 @@ Cabal >=1.18.1.5 && <1.25, base >=4.7 && <5, bytestring >=0.10.4.0 && <0.11, + conduit >=1.2.8 && <1.3, containers >=0.5.5.1 && <0.6, - directory >=1.2.1.0 && <1.3, + directory >=1.2.1.0 && <1.4, either >=4.4.1.1 && <4.5, filelock >=0.1.0.1 && <0.2, filepath >=1.3.0.2 && <1.5, - hpack >=0.14.0 && <0.16, + hpack >=0.17.0 && <0.18, http-client >=0.5.3.3 && <0.6, lifted-base >=0.2.3.8 && <0.3, microlens >=0.3.0.0 && <0.5, @@ -311,9 +318,10 @@ monad-logger >=0.3.13.1 && <0.4, mtl >=2.1.3.1 && <2.3, optparse-applicative ==0.13.*, - path >=0.5.9 && <0.6, + path >=0.5.8 && <0.6, path-io >=1.1.0 && <2.0.0, - stack >=1.3.2 && <1.4, + split >=0.2.3.1 && <0.3, + stack >=1.4.0 && <1.5, text >=1.2.0.4 && <1.3, transformers >=0.3.0.0 && <0.6 default-language: Haskell2010 @@ -336,29 +344,32 @@ conduit >=1.2.8 && <1.3, conduit-extra >=1.1.14 && <1.2, containers >=0.5.5.1 && <0.6, - cryptohash >=0.11.9 && <0.12, - directory >=1.2.1.0 && <1.3, + cryptonite ==0.19.*, + directory >=1.2.1.0 && <1.4, exceptions >=0.8.3 && <0.9, filepath >=1.4.0.0 && <1.5, - hspec >=2.2 && <2.4, - http-client-tls >=0.3.3 && <0.4, + hspec >=2.2 && <2.5, + hashable >=1.2.4.0 && <1.3, + http-client-tls >=0.3.4 && <0.4, http-conduit >=2.2.3 && <2.3, monad-logger >=0.3.20.1 && <0.4, neat-interpolation ==0.3.*, - path >=0.5.7 && <0.6, + optparse-applicative ==0.13.*, + path >=0.5.8 && <0.6, path-io >=1.1.0 && <2.0.0, resourcet >=1.1.8.1 && <1.2, retry >=0.6 && <0.8, - stack >=1.3.2 && <1.4, + stack >=1.4.0 && <1.5, temporary >=1.2.0.4 && <1.3, text >=1.2.2.1 && <1.3, transformers >=0.3.0.0 && <0.6, - mono-traversable >=0.10.2 && <0.11, + mono-traversable >=0.10.2 && <1.1, th-reify-many >=0.1.6 && <0.2, smallcheck >=1.1.1 && <1.2, bytestring >=0.10.6.0 && <0.11, store >=0.2.1.0 && <0.4, - vector >=0.11.0.0 && <0.12, + vector >=0.10.12.3 && <0.13, + unordered-containers >=0.2.7.1 && <0.3, template-haskell >=2.10.0.0 && <2.11, yaml >=0.8.20 && <0.9 default-language: Haskell2010 @@ -394,9 +405,9 @@ conduit >=1.2.8 && <1.3, conduit-extra >=1.1.14 && <1.2, containers >=0.5.5.1 && <0.6, - directory >=1.2.1.0 && <1.3, + directory >=1.2.1.0 && <1.4, filepath >=1.3.0.2 && <1.5, - hspec >=2.2 && <2.4, + hspec >=2.2 && <2.5, process >=1.2.0.0 && <1.5, resourcet >=1.1.8.1 && <1.2, temporary >=1.2.0.4 && <1.3, diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -12,21 +12,25 @@ packages: - zlib extra-deps: +- Cabal-1.24.2.0 - th-utilities-0.2.0.1 - store-0.3 - store-core-0.3 - th-orphans-0.13.1 - http-client-0.5.3.3 -- http-client-tls-0.3.3 +- http-client-tls-0.3.4 - http-conduit-2.2.3 - optparse-applicative-0.13.0.0 - text-metrics-0.1.0 - pid1-0.1.0.0 - aeson-1.0.2.1 -- hpack-0.15.0 +- hpack-0.17.0 - persistent-2.6 - persistent-template-2.5.1.6 - persistent-sqlite-2.6 +- cryptohash-sha256-0.11.100.1 +- ed25519-0.0.5.0 +- hackage-security-0.5.2.2 flags: stack: hide-dependency-versions: true