diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 8f0b94d40d..6c1fb60bbd 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -7,10 +7,10 @@ and use the provided template to include all necessary details. The more detailed your report, the faster it can be resolved and will ensure it is resolved in the right way. Once your bug has been resolved, the responsible -will tag the issue as _Needs confirmation_ and assign the issue back to you. -Once you have tested and confirmed that the issue is resolved, close the issue. -If you are not a member of the project, you will be asked for confirmation and -we will close it. +person will tag the issue as _Needs confirmation_ and assign the issue back to +you. Once you have tested and confirmed that the issue is resolved, close the +issue. If you are not a member of the project, you will be asked for +confirmation and we will close it. ## Documentation diff --git a/ChangeLog.md b/ChangeLog.md index 3235fe3a66..1ebe206466 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,6 +6,12 @@ Release notes: Major changes: +* Complete overhaul of how snapshots are defined, the `packages` and + `extra-deps` fields, and a number of related items. For full + details, please see + [the writeup on these changes](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots). [PR #3249](https://github.com/commercialhaskell/stack/pull/3249), + see the PR description for a number of related issues. + Behavior changes: * `stack profile` and `stack trace` now add their extra RTS arguments for @@ -37,9 +43,40 @@ Other enhancements: * `--[no-]haddock-hyperlink-source` flag added which allows toggling of sources being included in Haddock output. See [#3099](https://github.com/commercialhaskell/stack/issues/3099) +* `stack ghci` will now skip building all local targets, even if they have + downstream deps, as long as it's registered in the DB. +* The pvp-bounds feature now supports adding `-revision` to the end of + each value, e.g. `pvp-bounds: both-revision`. This means that, when + uploading to Hackage, Stack will first upload your tarball with an + unmodified `.cabal` file, and then upload a cabal file revision with + the PVP bounds added. This can be useful—especially combined + with the + [Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as + a method to ensure PVP compliance without having to proactively fix + bounds issues for Stackage maintenance. +* Expose a `save-hackage-creds` configuration option +* On GHC <= 7.8, filters out spurious linker warnings on windows + See [#3127](https://github.com/commercialhaskell/stack/pull/3127) +* Better error messages when creating or building packages which alias + wired-in packages. See + [#3172](https://github.com/commercialhaskell/stack/issues/3172). +* MinGW bin folder now is searched for dynamic libraries. See [#3126](https://github.com/commercialhaskell/stack/issues/3126) +* When using Nix, nix-shell now depends always on git to prevent runtime errors + while fetching metadata +* The `stack unpack` command now accepts a form where an explicit + Hackage revision hash is specified, e.g. `stack unpack + foo-1.2.3@gitsha1:deadbeef`. Note that this should be considered + _experimental_, Stack will likely move towards a different hash + format in the future. +* `GitSHA1` is now `StaticSHA256` and is implemented using the `StaticSize 64 ByteString` for improved performance. + See [#3006](https://github.com/commercialhaskell/stack/issues/3006) Bug fixes: +* Building all executables only happens once instead of every + time. See + [#3229](https://github.com/commercialhaskell/stack/issues/3229) for + more info. * Fixes case where `stack build --profile` might not cause executables / tests / benchmarks to be rebuilt. See [#2984](https://github.com/commercialhaskell/stack/issues/2984) @@ -56,7 +93,17 @@ Bug fixes: package database for wired-in-packages (ghc, base, etc). See [#3084](https://github.com/commercialhaskell/stack/issues/3084) * Fixes `stack --docker build` when user is part of libvirt/libvirtd - groups on Ubuntu Yakkety (16.10). See [#3092] + groups on Ubuntu Yakkety (16.10). + See [#3092](https://github.com/commercialhaskell/stack/issues/3092) +* Switching a package between extra-dep and local package now forces + rebuild (previously it wouldn't if versions were the same). + See [#2147](https://github.com/commercialhaskell/stack/issues/2147) +* `stack upload` no longer reveals your password when you type it on + MinTTY-based Windows shells, such as Cygwin and MSYS2. + See [#3142](https://github.com/commercialhaskell/stack/issues/3142) +* `stack script`'s import parser will now properly parse files that + have Windows-style line endings (CRLF) + ## 1.4.0 @@ -150,6 +197,8 @@ Other enhancements: * Upgraded `http-client-tls` version, which now offers support for the `socks5://` and `socks5h://` values in the `http_proxy` and `https_proxy` environment variables. +* Binary "stack upgrade" will now warn if the installed executable is not + on the PATH or shadowed by another entry. Bug fixes: @@ -1058,6 +1107,8 @@ Other enhancements: * `stack build --fast` turns off optimizations * Show progress while downloading package index [#1223](https://github.com/commercialhaskell/stack/issues/1223). +* Allow running tests on tarball created by sdist and upload + [#717](https://github.com/commercialhaskell/stack/issues/717). Bug fixes: diff --git a/doc/GUIDE.md b/doc/GUIDE.md index b442c14c4e..4b75f53996 100644 --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1425,7 +1425,7 @@ modified version of a dependency that hasn't yet been released upstream. Please note that when adding upstream packages directly to your project it is important to distinguish _local packages_ from the upstream _dependency -packages_. Otherwise you may have trouble running `stack GHCi`. See +packages_. Otherwise you may have trouble running `stack ghci`. See [stack.yaml documentation](yaml_configuration.md#packages) for more details. ## Flags and GHC options diff --git a/doc/custom_snapshot.md b/doc/custom_snapshot.md index 3b52790212..07fb4c52b6 100644 --- a/doc/custom_snapshot.md +++ b/doc/custom_snapshot.md @@ -1,29 +1,59 @@ # Custom Snapshots -Custom snapshots allow you to create your own snapshots, which provide a list of -specific hackage packages to use, along with flags and ghc-options. The -definition of a basic snapshot looks like the following: +Custom snapshots were totally reworked with the extensible snapshots +overhaul in Stack 1.6.0, see +[the writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) +and +[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). This +documentation covers the new syntax only. + +Custom snapshots allow you to create your own snapshots, which provide +a list of packages to use, along with flags, ghc-options, and a few +other settings. Custom snapshots may extend any other snapshot that +can be specified in a `resolver` field. The packages specified follow +the syntax of `extra-deps` in the `stack.yaml` file, with one +exception: to ensure reproducibility of snapshots, local directories +are not allowed for custom snapshots (as they are expected to change +regularly). ```yaml -resolver: ghc-8.0 +resolver: lts-8.21 # Inherits GHC version and package set +compiler: ghc-8.0.1 # Overwrites GHC version in the resolver, optional +name: my-snapshot # User-friendly name + +# Additional packages, follows extra-deps syntax packages: - - unordered-containers-0.2.7.1 - - hashable-1.2.4.0 - - text-1.2.2.1 +- unordered-containers-0.2.7.1 +- hashable-1.2.4.0 +- text-1.2.2.1 +# Override flags, can also override flags in the parent snapshot flags: unordered-containers: debug: true + +# Packages from the parent snapshot to ignore +drop-packages: +- wai-extra + +# Packages which should be hidden (affects script command's import +# parser +hidden: + wai: true + warp: false + +# Set GHC options for specific packages +ghc-options: + warp: + - -O2 ``` If you put this in a `snapshot.yaml` file in the same directory as your project, you can now use the custom snapshot like this: ```yaml -resolver: - name: simple-snapshot # Human readable name for the snapshot - location: simple-snapshot.yaml +resolver: snapshot.yaml ``` This is an example of a custom snapshot stored in the filesystem. They are @@ -38,24 +68,6 @@ For efficiency, URLs are treated differently. If I uploaded the snapshot to `https://domain.org/snapshot-1.yaml`, it is expected to be immutable. If you change that file, then you lose any reproducibility guarantees. -## Extending snapshots - -The example custom snapshot above uses a compiler resolver, and so has few -packages. We can also extend existing snapshots, by using the usual -[resolver setting found in stack configurations](yaml_configuration.md#resolver). -All possible resolver choices are valid, so this means that custom snapshots can -even extend other custom snapshots. - -Lets say that we want to use `lts-7.1`, but use a different version of `text` -than the one it comes with, `1.2.2.1`. To downgrade it to `1.2.2.0`, we need a -custom snapshot file with the following: - -```yaml -resolver: lts-7.1 -packages: - - text-1.2.2.0 -``` - ### Overriding the compiler The following snapshot specification will be identical to `lts-7.1`, but instead @@ -117,57 +129,3 @@ ghc-options: text: developer: true ``` - -## YAML format - -In summary, the YAML format of custom snapshots has the following fields which -are directly related to the same fields in the -[build configuration format](yaml_configuration.md): - -* `resolver`, which specifies which snapshot to extend. It takes the same values - as the [`resolver` field in stack.yaml](yaml_configuration.md#resolver). - -* `compiler`, which specifies or overrides the selection of compiler. If - `resolver` is absent, then a specification of `compiler` is required. Its - semantics are the same as the - [`compiler` field in stack.yaml](yaml_configuration.md#compiler). - -Some fields look similar, but behave differently: - -* `flags` specifies which cabal flags to use with each package. In order to - specify a flag for a package, it *must* be listed in the `packages` list. - -* `ghc-options`, which specifies which cabal flags to use with each package. In - order to specify ghc-options for a package, it *must* be listed in the - `packages` list. The `*` member of the map specifies flags that apply to every - package in the `packages` list. - -There are two fields which work differently than in the build configuration -format: - -* `packages`, which specifies a list of hackage package versions. Note that - when a package version is overridden, no `flags` or `ghc-options` are taken - from the snapshot that is being extended. If you want the same options as the - snapshot being extended, they must be re-specified. - -* `drop-packages`, which specifies a list of packages to drop from the snapshot - being overridden. - -## Future enhancements - -We plan to enhance extensible snapshots in several ways in the future. See -[issue #1265, about "implicit snapshots"](https://github.com/commercialhaskell/stack/issues/1265). -In summary, in the future: - -1) It will be possible to use a specific git repository + commit hash in the -`packages` list, like in regular stack.yaml configuration. Currently, custom -snapshots only work with packages on hackage. - -2) `stack.yaml` configurations will implicitly create a snapshot. This means -that the non-local packages will get shared between your projects, so there is -less redundant compilation! - -3) `flags` and `ghc-options` for packages which are not listed in `packages` are -silently ignored. See -[#2654](https://github.com/commercialhaskell/stack/issues/2654) for the current -status of this. diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md index ae1b3cfcd6..833ccac65e 100644 --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -63,15 +63,9 @@ such. ## macOS We generally test on the current version of macOS, but Stack is known to work -on El Capitan, Yosemite and Mavericks as well, and may also work on older +on Sierra, El Capitan, Yosemite and Mavericks as well, and may also work on older versions (YMMV). -**macOS Sierra warning**: There are new limitations in the dynamic linker that -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. - ### Installer script Run: @@ -88,10 +82,7 @@ Run: ### Using Homebrew -**macOS Sierra warning**: Homebrew's haskell-stack formula may not currently -work on Sierra, so we suggest using the manual method above for now. - -If you have a popular [brew](http://brew.sh/) tool installed, you can just do: +If you have the popular [brew](https://brew.sh/) tool installed, you can just do: brew install haskell-stack @@ -100,7 +91,7 @@ but tend to be updated within a day or two. * Normally, Homebrew will install from a pre-built binary (aka "pour from a bottle"), but if `brew` starts trying to build everything from source (which will take hours), see -[their FAQ on the topic](https://github.com/Homebrew/homebrew/blob/master/share/doc/homebrew/FAQ.md#why-do-you-compile-everything). +[their FAQ on the topic](https://github.com/Homebrew/brew/blob/master/docs/FAQ.md#why-do-you-compile-everything). ### Notes @@ -113,6 +104,9 @@ problems, see the linked FAQ entries: * [GHC 7.8.4 fails with `/usr/bin/ar: permission denied`](faq.md#usr-bin-ar-permission-denied) * [DYLD_LIBRARY_PATH is ignored](faq.md#dyld-library-path-ignored) + + +If you are on OS X 10.12 ("Sierra") and encounter [GHC panic while building, see this issue](https://github.com/commercialhaskell/stack/issues/2577) ## Ubuntu diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index b1b74e704a..7f52eeef58 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -16,8 +16,9 @@ and [non-project-specific](#non-project-specific-config) options in: - The project file itself may also contain non-project specific options *Note:* When stack is invoked outside a stack project it will source project -specific options from `~/.stack/global-project/stack.yaml`. Options in this file will -be ignored for a project with its own `/stack.yaml`. +specific options from `~/.stack/global-project/stack.yaml`. When stack is +invoked inside a stack project, only options from `/stack.yaml` are +used, and `~/.stack/global-project/stack.yaml` is ignored. ## Project-specific config @@ -40,156 +41,195 @@ it will be used even if you're using a snapshot that specifies a particular version. Similarly, `extra-deps` will shadow the version specified in the resolver. -### packages +### resolver + +Specifies which snapshot is to be used for this project. A snapshot +defines a GHC version, a number of packages available for +installation, and various settings like build flags. It is called a +resolver since a snapshot states how dependencies are resolved. There +are currently four resolver types: + +* LTS Haskell snapshots, e.g. `resolver: lts-2.14` +* Stackage Nightly snapshot, e.g. `resolver: nightly-2015-06-16` +* No snapshot, just use packages shipped with the compiler + * For GHC this looks like `resolver: ghc-7.10.2` + * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`. +* [Custom snapshot](custom_snapshot.md) + +Each of these resolvers will also determine what constraints are placed on the +compiler version. See the [compiler-check](#compiler-check) option for some +additional control over compiler version. + +### packages and extra-deps + +_NOTE_ The contents of this section have changed significantly since +extensible snapshots were implemented (see: +[writeup](https://www.fpcomplete.com/blog/2017/07/stacks-new-extensible-snapshots) +and +[PR #3249](https://github.com/commercialhaskell/stack/pull/3249)). Most +old syntax is still supported with newer versions of Stack, but will +not be documented here. Instead, this section contains the recommended +syntax as of Stack v1.6.0. + +There are two types of packages that can be defined in your +`stack.yaml` file: + +* __Project packages__, those which you are actually working on in + your current project. These are local file paths in your project + directory. +* __Extra dependencies__, which are packages provided locally on top + of the snapshot definition of available packages. These can come + from Hackage (or an alternative package index you've defined, see + [package-indices](#package-indices)), an HTTP(S) tarball, a Git or + Mercurial repository, or a local file path. -The `packages` section lists all local (project) packages. The term _local -package_ should be differentiated from a _dependency package_. A local package -is something that you are developing as part of the project. Whereas a -dependency package is an external package that your project depends on. +These two sets of packages are both installed into your local package database within your project. However, beyond that, they are completely different: -In its simplest usage, it will be a list of directories or HTTP(S) URLs to a -tarball or a zip. For example: +* Project packages will be built by default with a `stack build` + without specific targets. Extra dependencies will only be built if + they are depended upon. +* Test suites and benchmarks may be run for project packages. They are + never run for extra dependencies. + +The `packages` key is a simple list of file paths, which will be +treated as relative to the directory containing your `stack.yaml` +file. For example: ```yaml packages: - - . - - dir1/dir2 - - https://example.com/foo/bar/baz-0.0.2.tar.gz +- . +- dir1/dir2 ``` -Each package directory or location specified must have a valid cabal file -present. Note that the subdirectories of the directory are not searched for -cabal files. Subdirectories will have to be specified as independent items in -the list of packages. +Each package directory or location specified must have a valid cabal +file or hpack `package.yaml` file present. Note that the +subdirectories of the directory are not searched for cabal +files. Subdirectories will have to be specified as independent items +in the list of packages. When the `packages` field is not present, it defaults to looking for a package in the project's root directory: ```yaml packages: - - . +- . +``` + +The `extra-deps` key is given a list of all extra dependencies. If +omitted, it is taken as the empty list, e.g.: + +```yaml +extra-deps: [] ``` -#### Complex package locations (`location`) -More complex package locations can be specified in a key-value format with -`location` as a mandatory key. In addition to `location` some optional -key-value pairs can be specified to include specific subdirectories or to -specify package attributes as descibed later in this section. +It supports four different styles of values: -In its simplest form a `location` key can have a single value in the same way -as described above for single value items. Alternativel it can have key-value -pairs as subfields to describe a git or mercurial repository location. For -example: +#### Package index + +Packages can be stated by a name/version combination, which will be +looked up in the package index (by default, Hackage). The basic syntax +for this is: ```yaml -packages: -- location: . -- location: dir1/dir2 -- location: https://example.com/foo/bar/baz-0.0.2.tar.gz -- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip -- location: - git: git@github.com:commercialhaskell/stack.git - commit: 6a86ee32e5b869a877151f74064572225e1a0398 -- location: - hg: https://example.com/hg/repo - commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 +extra-deps: +- acme-missiles-0.3 ``` -Note: it is highly recommended that you only use SHA1 values for a Git or -Mercurial commit. Other values may work, but they are not officially supported, -and may result in unexpected behavior (namely, stack will not automatically -pull to update to new versions). +Using this syntax, the most recent Cabal file revision available will +be used. For more reproducibility of builds, it is recommended to +state the SHA256 hash of the cabal file contents as well, like this: -A `location` key can be accompanied by a `subdirs` key to look for cabal files -in a list of subdirectories as well in addition to the top level directory. +```yaml +extra-deps: +- acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 +``` + +__NOTE__ Future versions of Stack may support specifying revisions by +the revision number, providing more convenient than a hash with +slightly less guarantees of reproducibility. -This could be useful for mega-repos like -[wai](https://github.com/yesodweb/wai/) or -[digestive-functors](https://github.com/jaspervdj/digestive-functors). +#### Local file path + +Like `packages`, local file paths can be used in `extra-deps`, and +will be relative to the directory containing the `stack.yaml` file. -The `subdirs` key can have multiple nested series items specifying a list of -subdirectories. For example: ```yaml -packages: -- location: . - subdirs: - - subdir1 - - subdir2 -- location: - git: git@github.com:yesodweb/wai - commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f - subdirs: - - auto-update - - wai -- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - subdirs: - - auto-update - - wai +extra-deps: +- vendor/somelib ``` -#### Local dependency packages (`extra-dep`) -A `location` key can be accompanied by an `extra-dep` key. When the -`extra-dep` key is set to `true` it indicates that the package should be -treated in the same way as a dependency package and not as part of the project. -This means the following: -* A _dependency package_ is built only if a user package or its dependencies - depend on it. Note that a regular _project package_ is built anyway even if - no other package depends on it. -* Its test suites and benchmarks will not be run. -* It will not be directly loaded in ghci when `stack ghci` is run. This is - important because if you specify huge dependencies as project packages then - ghci will have a nightmare loading everything. +Note that if a local directory can be parsed as a package identifier, +Stack will treat it as a package identifier. In other words, if you +have a local directory named `foo-1.2.3`, instead of: -This is especially useful when you are tweaking upstream packages or want to -use latest versions of the upstream packages which are not yet on Hackage or -Stackage. +```yaml +extra-deps: +- foo-1.2.3 +``` + +You should use the following to be explicit: -For example: ```yaml -packages: -- location: . -- location: vendor/binary - extra-dep: true -- location: - git: git@github.com:yesodweb/wai - commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f - subdirs: - - auto-update - - wai - extra-dep: true +extra-deps: +- ./foo-1.2.3 ``` -### extra-deps +#### Git and Mercurial repos -This is a list of package identifiers for additional packages from upstream to -be included. This is usually used to augment an LTS Haskell or Stackage Nightly -snapshot with a package that is not present or is at an different version than you -wish to use. +You can give a Git or Mercurial repo at a specific commit, and Stack +will clone that repo. ```yaml extra-deps: -- acme-missiles-0.3 +- git: git@github.com:commercialhaskell/stack.git + commit: 6a86ee32e5b869a877151f74064572225e1a0398 +- hg: https://example.com/hg/repo + commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 ``` -Note that the `extra-dep` attribute in the `packages` section as described in -an earlier section is used for non-index local or remote packages while the -`extra-deps` section is for packages to be automatically pulled from an index -like Hackage. +__NOTE__ It is highly recommended that you only use SHA1 values for a +Git or Mercurial commit. Other values may work, but they are not +officially supported, and may result in unexpected behavior (namely, +Stack will not automatically pull to update to new versions). -### resolver +A common practice in the Haskell world is to use "megarepos", or +repositories with multiple packages in various subdirectories. Some +common examples include [wai](https://github.com/yesodweb/wai/) and +[digestive-functors](https://github.com/jaspervdj/digestive-functors). To +support this, you may also specify `subdirs` for repositories, e.g.: -Specifies how dependencies are resolved. There are currently four resolver types: +```yaml +extra-deps: +- git: git@github.com:yesodweb/wai + commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f + subdirs: + - auto-update + - wai +``` -* LTS Haskell snapshots, e.g. `resolver: lts-2.14` -* Stackage Nightly snapshot, e.g. `resolver: nightly-2015-06-16` -* No snapshot, just use packages shipped with the compiler - * For GHC this looks like `resolver: ghc-7.10.2` - * For GHCJS this looks like `resolver: ghcjs-0.1.0_ghc-7.10.2`. -* [Custom snapshot](custom_snapshot.md) +If unspecified, `subdirs` defaults to `subdirs: [.]`, or looking for a +package in the root of the repo. -Each of these resolvers will also determine what constraints are placed on the -compiler version. See the [compiler-check](#compiler-check) option for some -additional control over compiler version. +#### HTTP(S) URLs + +This one's pretty straightforward: you can use HTTP and HTTPS URLs +referring to either tarballs or ZIP files. + +__NOTE__ Stack assumes that these files never change after downloading +to avoid needing to make an HTTP request on each build. + +```yaml +extra-deps: +- https://example.com/foo/bar/baz-0.0.2.tar.gz +- location: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + subdirs: + - wai + - warp +``` + +Note that HTTP(S) URLs also support `subdirs` like repos to allow for +archives of megarepos. In order to leverage this, use `location: +http://...`. ### flags @@ -547,6 +587,16 @@ pvp-bounds: none For more information, see [the announcement blog post](https://www.fpcomplete.com/blog/2015/09/stack-pvp). +__NOTE__ Since Stack 1.5.0, each of the values listed above supports +adding `-revision` to the end of each value, e.g. `pvp-bounds: +both-revision`. This means that, when uploading to Hackage, Stack will +first upload your tarball with an unmodified `.cabal` file, and then +upload a cabal file revision with the PVP bounds added. This can be +useful—especially combined with the +[Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as +a method to ensure PVP compliance without having to proactively fix +bounds issues for Stackage maintenance. + ### modify-code-page (Since 0.1.6) @@ -729,6 +779,17 @@ in the directories it creates. Source control tools can be specified with the templates: scm-init: git ``` + +### save-hackage-creds + +Controls whether, when using `stack upload`, the user's Hackage +username and password are stored in a local file. Default: true. + +```yaml +save-hackage-creds: true +``` + +Since 1.5.0 # urls diff --git a/etc/dockerfiles/stack-build/lts-8.0/Dockerfile b/etc/dockerfiles/stack-build/lts-8.0/Dockerfile index c848930792..906e3d9f98 100644 --- a/etc/dockerfiles/stack-build/lts-8.0/Dockerfile +++ b/etc/dockerfiles/stack-build/lts-8.0/Dockerfile @@ -42,8 +42,9 @@ RUN stack --system-ghc --resolver=$LTS_SLUG --local-bin-path=/usr/local/bin inst # Install proper 'pid1' init daemon # -RUN wget -O- "https://github.com/fpco/pid1/releases/download/pid1%2F$PID1_VERSION/pid1-$PID1_VERSION-linux-x86_64.tar.gz" |tar xzf - -C /usr/local - +RUN wget -O- "https://github.com/fpco/pid1/releases/download/pid1%2F$PID1_VERSION/pid1-$PID1_VERSION-linux-x86_64.tar.gz" | tar xzf - -C /usr/local && \ + chown root:root /usr/local/sbin && \ + chown root:root /usr/local/sbin/pid1 # # Set up pid1 entrypoint and default command # diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs index 55d0828c57..093dd1301a 100644 --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -13,8 +13,9 @@ module Control.Concurrent.Execute import Control.Applicative import Control.Concurrent.Async (Concurrently (..), async) import Control.Concurrent.STM -import Control.Exception +import Control.Exception (mask) import Control.Monad (join, unless) +import Control.Monad.IO.Unlift import Data.Foldable (sequenceA_) import Data.Set (Set) import qualified Data.Set as Set diff --git a/src/Control/Monad/IO/Unlift.hs b/src/Control/Monad/IO/Unlift.hs new file mode 100644 index 0000000000..9d59e42687 --- /dev/null +++ b/src/Control/Monad/IO/Unlift.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE RankNTypes #-} +-- | FIXME to be moved to an external package at some point +module Control.Monad.IO.Unlift + ( MonadUnliftIO (..) + , UnliftIO (..) + , askRunIO + , withUnliftIO + , withRunIO + , toIO + , MonadIO (..) + + , Res.ResourceT + , runResourceT + , liftResourceT + , runConduitRes + + , catch + , catchIO + , catchAny + , catchAnyDeep + , catchJust + + , handle + , handleIO + , handleAny + , handleAnyDeep + , handleJust + + , try + , tryIO + , tryAny + , tryAnyDeep + , tryJust + + , ES.Exception (..) + , ES.SomeException (..) + , E.ErrorCall + , ES.IOException + , E.assert + , ES.MonadThrow -- FIXME perhaps completely ditch MonadThrow? + , throwIO + , ES.throwM + , ES.impureThrow + , ES.Handler (..) + , evaluate + , bracket + , bracket_ + , bracketOnError + , bracketOnError_ + , finally + , withException + , onException + + , M.MVar + , newMVar + , modifyMVar + , modifyMVar_ + , takeMVar + , withMVar + ) where + +import Control.DeepSeq (NFData) +import Control.Monad.IO.Class +import Control.Monad.Logger (LoggingT (..), NoLoggingT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) +import qualified Control.Monad.Trans.Resource as Res +import qualified Control.Monad.Trans.Resource.Internal as Res +import qualified Control.Exception as E (ErrorCall, evaluate, assert) +import qualified Control.Exception.Safe as ES +import qualified Data.Conduit as Con +import Data.Void (Void) +import qualified Control.Concurrent.MVar as M + +-- FIXME consider making MonadThrow a superclass and demanding that +-- throwIO = throwM +class MonadIO m => MonadUnliftIO m where + askUnliftIO :: m (UnliftIO m) + -- Would be better, but GHC hates us + -- askUnliftIO :: m (forall a. m a -> IO a) +instance MonadUnliftIO IO where + askUnliftIO = return (UnliftIO id) +instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where + askUnliftIO = ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r)) +instance MonadUnliftIO m => MonadUnliftIO (LoggingT m) where + askUnliftIO = LoggingT $ \f -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runLoggingT f)) +instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where + askUnliftIO = NoLoggingT $ + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . runNoLoggingT)) +instance MonadUnliftIO m => MonadUnliftIO (Res.ResourceT m) where + askUnliftIO = Res.ResourceT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip Res.unResourceT r)) + +{- Invalid instance, violates the laws +instance MonadUnliftIO (StateT s IO) where + askUnliftIO = StateT $ \s0 -> do + let u = UnliftIO $ \m -> do + (a, s1) <- runStateT m s0 -- Invalid by construction! Fails the MonadUnliftIO laws + return a + return (u, s0) +-} + +newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a } + +askRunIO :: MonadUnliftIO m => m (m a -> IO a) +askRunIO = fmap unliftIO askUnliftIO + +withUnliftIO :: MonadUnliftIO m => (UnliftIO m -> IO a) -> m a +withUnliftIO inner = askUnliftIO >>= liftIO . inner + +withRunIO :: MonadUnliftIO m => ((m a -> IO a) -> IO b) -> m b +withRunIO inner = askRunIO >>= liftIO . inner + +toIO :: MonadUnliftIO m => m a -> m (IO a) +toIO m = withRunIO $ \run -> return $ run m + +runResourceT :: MonadUnliftIO m => Res.ResourceT m a -> m a +runResourceT m = withRunIO $ \run -> Res.runResourceT $ Res.transResourceT run m + +liftResourceT :: MonadIO m => Res.ResourceT IO a -> Res.ResourceT m a +liftResourceT (Res.ResourceT f) = Res.ResourceT $ liftIO . f + +runConduitRes :: MonadUnliftIO m => Con.ConduitM () Void (Res.ResourceT m) r -> m r +runConduitRes = runResourceT . Con.runConduit + +catch :: (MonadUnliftIO m, ES.Exception e) => m a -> (e -> m a) -> m a +catch x y = withUnliftIO $ \u -> unliftIO u x `ES.catch` (unliftIO u . y) + +catchIO :: MonadUnliftIO m => m a -> (ES.IOException -> m a) -> m a +catchIO = catch + +catchAny :: MonadUnliftIO m => m a -> (ES.SomeException -> m a) -> m a +catchAny = catch + +catchAnyDeep :: (NFData a, MonadUnliftIO m) => m a -> (ES.SomeException -> m a) -> m a +catchAnyDeep x y = withUnliftIO $ \u -> unliftIO u x `ES.catchAnyDeep` (unliftIO u . y) + +catchJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a +catchJust f a b = a `catch` \e -> maybe (liftIO (ES.throwM e)) b $ f e + +handle :: (MonadUnliftIO m, ES.Exception e) => (e -> m a) -> m a -> m a +handle = flip catch + +handleIO :: MonadUnliftIO m => (ES.IOException -> m a) -> m a -> m a +handleIO = handle + +handleAny :: MonadUnliftIO m => (ES.SomeException -> m a) -> m a -> m a +handleAny = handle + +handleAnyDeep :: (MonadUnliftIO m, NFData a) => (ES.SomeException -> m a) -> m a -> m a +handleAnyDeep = flip catchAnyDeep + +handleJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a +handleJust f = flip (catchJust f) + +try :: (MonadUnliftIO m, ES.Exception e) => m a -> m (Either e a) +try m = withRunIO $ \run -> ES.try (run m) + +tryIO :: MonadUnliftIO m => m a -> m (Either ES.SomeException a) +tryIO = try + +tryAny :: MonadUnliftIO m => m a -> m (Either ES.SomeException a) +tryAny = try + +tryAnyDeep :: (MonadUnliftIO m, NFData a) => m a -> m (Either ES.SomeException a) +tryAnyDeep m = withRunIO $ \run -> ES.tryAnyDeep (run m) + +tryJust :: (MonadUnliftIO m, ES.Exception e) => (e -> Maybe b) -> m a -> m (Either b a) +tryJust f m = withRunIO $ \run -> ES.tryJust f (run m) + +evaluate :: MonadIO m => a -> m a +evaluate = liftIO . E.evaluate + +bracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c +bracket x y z = withUnliftIO $ \u -> ES.bracket + (unliftIO u x) + (unliftIO u . y) + (unliftIO u . z) + +bracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c +bracket_ x y z = withUnliftIO $ \u -> ES.bracket_ + (unliftIO u x) + (unliftIO u y) + (unliftIO u z) + +bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c +bracketOnError x y z = withUnliftIO $ \u -> ES.bracketOnError + (unliftIO u x) + (unliftIO u . y) + (unliftIO u . z) + +bracketOnError_ :: MonadUnliftIO m => m a -> m b -> m c -> m c +bracketOnError_ x y z = withUnliftIO $ \u -> ES.bracketOnError_ + (unliftIO u x) + (unliftIO u y) + (unliftIO u z) + +finally :: MonadUnliftIO m => m a -> m b -> m a +finally x y = withUnliftIO $ \u -> ES.finally + (unliftIO u x) + (unliftIO u y) + +withException :: (MonadUnliftIO m, ES.Exception e) + => m a -> (e -> m b) -> m a +withException x y = withUnliftIO $ \u -> ES.withException + (unliftIO u x) + (unliftIO u . y) + +onException :: MonadUnliftIO m => m a -> m b -> m a +onException x y = withUnliftIO $ \u -> ES.onException + (unliftIO u x) + (unliftIO u y) + +-- FIXME I'm not too happy about differing behavior between throwM and throwIO +throwIO :: (MonadIO m, ES.Exception e) => e -> m a +throwIO = liftIO . ES.throwM + +newMVar :: MonadIO m => a -> m (M.MVar a) +newMVar = liftIO . M.newMVar + +modifyMVar :: MonadUnliftIO m => M.MVar a -> (a -> m (a, b)) -> m b +modifyMVar var f = withRunIO $ \run -> M.modifyMVar var (run . f) + +modifyMVar_ :: MonadUnliftIO m => M.MVar a -> (a -> m a) -> m () +modifyMVar_ var f = withRunIO $ \run -> M.modifyMVar_ var (run . f) + +takeMVar :: MonadIO m => M.MVar a -> m a +takeMVar = liftIO . M.takeMVar + +withMVar :: MonadUnliftIO m => M.MVar a -> (a -> m b) -> m b +withMVar var f = withRunIO $ \run -> M.withMVar var (run . f) diff --git a/src/Data/IORef/RunOnce.hs b/src/Data/IORef/RunOnce.hs index 4244d31e2d..7ae86d1749 100644 --- a/src/Data/IORef/RunOnce.hs +++ b/src/Data/IORef/RunOnce.hs @@ -1,16 +1,16 @@ module Data.IORef.RunOnce (runOnce) where -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Data.IORef -runOnce :: MonadIO m => m a -> m (m a) -runOnce f = do - ref <- liftIO $ newIORef Nothing - return $ do - mval <- liftIO $ readIORef ref +runOnce :: (MonadUnliftIO m, MonadIO n) => m a -> m (n a) +runOnce f = withRunIO $ \runIO -> do + ref <- newIORef Nothing + return $ liftIO $ do + mval <- readIORef ref case mval of Just val -> return val Nothing -> do - val <- f - liftIO $ writeIORef ref (Just val) + val <- runIO f + writeIORef ref (Just val) return val diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs index 5073b7616b..f0e530507a 100644 --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -15,10 +15,8 @@ module Data.Store.VersionTagged ) where import Control.Applicative -import Control.Exception.Lifted (catch, IOException, assert) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString as BS import Data.Data (Data) import qualified Data.Map as M @@ -61,7 +59,7 @@ storeEncodeFile pokeFunc peekFunc fp x = do -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the -- version tag. -versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadIO m, MonadLogger m, MonadBaseControl IO m) +versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File @@ -81,7 +79,7 @@ versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do storeEncodeFile pokeFunc peekFunc fp x return x -versionedDecodeFileImpl :: (Store a, MonadIO m, MonadLogger m, MonadBaseControl IO m) +versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m) => Peek a -> Path loc File -> m (Maybe a) @@ -104,5 +102,12 @@ storeVersionConfig name hash = (namedVersionConfig name hash) , "Data.ByteString.Internal.ByteString" ] , vcRenames = M.fromList - [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") ] + [ ( "Data.Maybe.Maybe", "GHC.Base.Maybe") + , ( "Stack.Types.Compiler.CVActual" + , "Stack.Types.Compiler.'CVActual" + ) + , ( "Stack.Types.Compiler.CVWanted" + , "Stack.Types.Compiler.'CVWanted" + ) + ] } diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs index ca94ea3f63..2172e45600 100644 --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -20,14 +20,11 @@ module Network.HTTP.Download , setGithubHeaders ) where -import Control.Exception (Exception) -import Control.Exception.Safe (handleIO) import Control.Monad (void) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger, logDebug) import qualified Data.ByteString.Lazy as L -import Data.Conduit (runConduit, runConduitRes, (.|), yield) +import Data.Conduit (runConduit, (.|), yield) import Data.Conduit.Binary (sourceHandle) import qualified Data.Conduit.Binary as CB import Data.Foldable (forM_) diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index fad8236b73..6029aa46e8 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -30,8 +30,8 @@ import qualified Data.Text.Encoding as Text import Control.Applicative import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.Catch (Handler (..)) +import Control.Monad.IO.Unlift hiding (Handler (..)) -- FIXME when safe-exceptions uses exceptions's Handler, we can get rid of this and the dependency on exceptions import Control.Monad.Logger (logDebug, MonadLogger) import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) import Crypto.Hash @@ -55,7 +55,7 @@ import Network.HTTP.Types.Header (hContentLength, hContentMD5) import Path import Prelude -- Fix AMP warning import System.Directory -import System.FilePath ((<.>)) +import qualified System.FilePath as FP ((<.>)) import System.IO -- | A request together with some checks to perform. @@ -188,15 +188,17 @@ hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteStr hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req) -- 'Control.Retry.recovering' customized for HTTP failures -recoveringHttp :: (MonadMask m, MonadIO m) +recoveringHttp :: MonadUnliftIO m => RetryPolicy -> m a -> m a recoveringHttp retryPolicy = #if MIN_VERSION_retry(0,7,0) - recovering retryPolicy handlers . const + helper $ recovering retryPolicy handlers . const #else - recovering retryPolicy handlers + helper $ recovering retryPolicy handlers #endif where + helper wrapper action = withRunIO $ \run -> wrapper (run action) + handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO] alwaysRetryHttp :: Monad m => HttpException -> m Bool @@ -243,7 +245,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do if p then m >> return True else return False fp = toFilePath destpath - fptmp = fp <.> "tmp" + fptmp = fp FP.<.> "tmp" dir = toFilePath $ parent destpath getShouldDownload = do diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index 555369a47e..2050ab4343 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -29,8 +29,8 @@ module Options.Applicative.Builder.Extra ,unescapeBashArg ) where -import Control.Exception (IOException, catch) import Control.Monad (when, forM) +import Control.Monad.IO.Unlift import Data.Either.Combinators import Data.List (isPrefixOf) import Data.Maybe diff --git a/src/Path/CheckInstall.hs b/src/Path/CheckInstall.hs new file mode 100644 index 0000000000..ab19d99ec7 --- /dev/null +++ b/src/Path/CheckInstall.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Path.CheckInstall where + +import Control.Monad (unless) +import Control.Monad.Extra (anyM, (&&^)) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Foldable (forM_) +import Data.Text (Text) +import qualified Data.Text as T +import qualified System.Directory as D +import qualified System.FilePath as FP + +-- | Checks if the installed executable will be available on the user's +-- PATH. This doesn't use @envSearchPath menv@ because it includes paths +-- only visible when running in the stack environment. +warnInstallSearchPathIssues :: (MonadIO m, MonadLogger m) => FilePath -> [Text] -> m () +warnInstallSearchPathIssues destDir installed = do + searchPath <- liftIO FP.getSearchPath + destDirIsInPATH <- liftIO $ + anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir) (D.canonicalizePath dir)) searchPath + if destDirIsInPATH + then forM_ installed $ \exe -> do + mexePath <- (liftIO . D.findExecutable . T.unpack) exe + case mexePath of + Just exePath -> do + exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath + unless (exeDir `FP.equalFilePath` destDir) $ do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: The \"" + , exe + , "\" executable found on the PATH environment variable is " + , T.pack exePath + , ", and not the version that was just installed." + ] + $logWarn $ T.concat + [ "This means that \"" + , exe + , "\" calls on the command line will not use this version." + ] + Nothing -> do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: Installation path " + , T.pack destDir + , " is on the PATH but the \"" + , exe + , "\" executable that was just installed could not be found on the PATH." + ] + else do + $logWarn "" + $logWarn $ T.concat + [ "WARNING: Installation path " + , T.pack destDir + , " not found on the PATH environment variable" + ] diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs index b5f86314db..b24222bbc7 100644 --- a/src/Path/Extra.hs +++ b/src/Path/Extra.hs @@ -20,8 +20,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T import Control.Monad (liftM) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Data.Bool (bool) import Path import Path.IO diff --git a/src/Path/Find.hs b/src/Path/Find.hs index a8f4599349..b9f2e1448a 100644 --- a/src/Path/Find.hs +++ b/src/Path/Find.hs @@ -9,11 +9,9 @@ module Path.Find ,findInParents) where -import Control.Exception (evaluate) import Control.DeepSeq (force) import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import System.IO.Error (isPermissionError) import Data.List import Path diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 41d8ad1a0c..b43226d6b5 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -20,13 +20,10 @@ module Stack.Build ,CabalVersionException(..)) where -import Control.Exception (Exception) import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Resource -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import Data.Aeson (Value (Object, Array), (.=), object) import Data.Function import qualified Data.HashMap.Strict as HM @@ -36,7 +33,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Map.Strict (Map) -import Data.Maybe (catMaybes) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -50,7 +46,7 @@ import Data.Typeable (Typeable) import qualified Data.Vector as V import qualified Data.Yaml as Yaml import Path -import Prelude hiding (FilePath, writeFile) +import Prelude hiding (writeFile) import Stack.Build.ConstructPlan import Stack.Build.Execute import Stack.Build.Haddock @@ -59,9 +55,9 @@ import Stack.Build.Source import Stack.Build.Target import Stack.Fetch as Fetch import Stack.Package -import Stack.PackageIndex -import Stack.PrettyPrint +import Stack.PackageLocation (loadSingleRawCabalFile) import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.Package @@ -78,7 +74,6 @@ import System.FileLock (FileLock, unlockFile) #ifdef WINDOWS import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) -import qualified Control.Monad.Catch as Catch #endif -- | Build. @@ -86,7 +81,7 @@ import qualified Control.Monad.Catch as Catch -- If a buildLock is passed there is an important contract here. That lock must -- protect the snapshot, and it must be safe to unlock it if there are no further -- modifications to the snapshot to be performed by this build. -build :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +build :: (StackM env m, HasEnvConfig env) => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files -> Maybe FileLock -> BuildOptsCLI @@ -97,7 +92,7 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) menv <- getMinimalEnvOverride - (targets, mbp, locals, extraToBuild, extraDeps, sourceMap) <- loadSourceMapFull NeedTargets boptsCli + (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli -- Set local files, necessary for file watching stackYaml <- view stackYamlL @@ -114,11 +109,9 @@ build setLocalFiles mbuildLk boptsCli = fixCodePage $ do , getInstalledSymbols = symbols } sourceMap - warnMissingExtraDeps installedMap extraDeps - baseConfigOpts <- mkBaseConfigOpts boptsCli plan <- withLoadPackage $ \loadPackage -> - constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap + constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) allowLocals <- view $ configL.to configAllowLocals unless allowLocals $ case justLocals plan of @@ -184,25 +177,6 @@ newtype CabalVersionException = CabalVersionException { unCabalVersionException instance Show CabalVersionException where show = unCabalVersionException instance Exception CabalVersionException -warnMissingExtraDeps - :: (StackM env m, HasConfig env) - => InstalledMap -> Map PackageName Version -> m () -warnMissingExtraDeps installed extraDeps = do - missingExtraDeps <- - fmap catMaybes $ forM (Map.toList extraDeps) $ \(n, v) -> - if Map.member n installed - then return Nothing - else do - vs <- getPackageVersions n - if Set.null vs - then return $ Just $ - fromString (packageNameString n ++ "-" ++ versionString v) - else return Nothing - unless (null missingExtraDeps) $ - $prettyWarn $ - "Some extra-deps are neither installed nor in the index:" <> line <> - indent 4 (bulletedList missingExtraDeps) - -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten :: MonadLogger m => [LocalPackage] -> Plan -> m () @@ -311,18 +285,18 @@ mkBaseConfigOpts boptsCli = do } -- | Provide a function for loading package information from the package index -withLoadPackage :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) - => ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a) +withLoadPackage :: (StackM env m, HasEnvConfig env) + => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> m a) -> m a withLoadPackage inner = do econfig <- view envConfigL - withCabalLoader $ \cabalLoader -> - inner $ \name version flags ghcOptions -> do - bs <- cabalLoader $ PackageIdentifier name version + menv <- getMinimalEnvOverride + root <- view projectRootL + run <- askRunIO + withCabalLoader $ \loadFromIndex -> + inner $ \loc flags ghcOptions -> do + bs <- run $ loadSingleRawCabalFile loadFromIndex menv root loc - -- Intentionally ignore warnings, as it's not really - -- appropriate to print a bunch of warnings out while - -- resolving the package index. (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags ghcOptions) bs return pkg where @@ -356,13 +330,13 @@ fixCodePage inner = do let setInput = origCPI /= expected setOutput = origCPO /= expected fixInput - | setInput = Catch.bracket_ + | setInput = bracket_ (liftIO $ do setConsoleCP expected) (liftIO $ setConsoleCP origCPI) | otherwise = id fixOutput - | setOutput = Catch.bracket_ + | setOutput = bracket_ (liftIO $ do setConsoleOutputCP expected) (liftIO $ setConsoleOutputCP origCPO) diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 4484ba9046..b889ea8477 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -33,13 +33,10 @@ module Stack.Build.Cache import Control.Applicative import Control.DeepSeq (NFData) -import Control.Exception.Safe (handleIO, tryAnyDeep) import Control.Monad (liftM) -import Control.Monad.Catch (MonadThrow, MonadCatch) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Control (MonadBaseControl) import Crypto.Hash (hashWith, SHA256(..)) import Data.Binary (Binary (..)) import qualified Data.Binary as Binary @@ -97,7 +94,7 @@ getInstalledExes loc = do mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files -- | Mark the given executable as installed -markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m) +markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do dir <- exeInstalledDir loc @@ -115,25 +112,25 @@ markExeInstalled loc ident = do liftIO $ writeFile fp "Installed" -- | Mark the given executable as not installed -markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadCatch m) +markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) => InstallLocation -> PackageIdentifier -> m () markExeNotInstalled loc ident = do dir <- exeInstalledDir loc ident' <- parseRelFile $ packageIdentifierString ident - ignoringAbsence (removeFile $ dir ident') + liftIO $ ignoringAbsence (removeFile $ dir ident') -- | Try to read the dirtiness cache for the given package directory. -tryGetBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env, MonadBaseControl IO m) +tryGetBuildCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env) => Path Abs Dir -> m (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache dir = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir -- | Try to read the dirtiness cache for the given package directory. -tryGetConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetConfigCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m (Maybe ConfigCache) tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir -- | Try to read the mod time of the cabal file from the last build -tryGetCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetCabalMod :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m (Maybe ModTime) tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir @@ -165,7 +162,7 @@ writeCabalMod dir x = do $(versionedEncodeFile modTimeVC) fp x -- | Delete the caches for the project. -deleteCaches :: (MonadIO m, MonadReader env m, MonadCatch m, HasEnvConfig env) +deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => Path Abs Dir -> m () deleteCaches dir = do {- FIXME confirm that this is acceptable to remove @@ -173,7 +170,7 @@ deleteCaches dir = do removeFileIfExists bfp -} cfp <- configCacheFile dir - ignoringAbsence (removeFile cfp) + liftIO $ ignoringAbsence (removeFile cfp) flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed @@ -187,7 +184,7 @@ flagCacheFile installed = do return $ dir rel -- | Loads the flag cache for the given installed extra-deps -tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +tryGetFlagCache :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Installed -> m (Maybe ConfigCache) tryGetFlagCache gid = do @@ -220,7 +217,7 @@ unsetTestSuccess dir = do $(versionedEncodeFile testSuccessVC) fp False -- | Check if the test suite already passed -checkTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadBaseControl IO m, MonadLogger m) +checkTestSuccess :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) => Path Abs Dir -> m Bool checkTestSuccess dir = @@ -314,7 +311,7 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do -- | Check the cache for a precompiled package matching the given -- configuration. -readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m, MonadBaseControl IO m) +readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadUnliftIO m, MonadLogger m) => PackageIdentifier -- ^ target package -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 9ec800b912..3307ba6f5c 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -10,21 +11,23 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Construct a @Plan@ for how to build module Stack.Build.ConstructPlan ( constructPlan ) where -import Control.Exception.Lifted import Control.Monad -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger +import Control.Monad.Reader (runReaderT) import Control.Monad.RWS.Strict import Control.Monad.State.Strict (execState) -import Control.Monad.Trans.Resource import Data.Either import Data.Function +import qualified Data.HashSet as HashSet import Data.List +import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map @@ -50,12 +53,14 @@ import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source import Stack.BuildPlan +import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump import Stack.PackageIndex import Stack.PrettyPrint import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -132,9 +137,9 @@ type M = RWST IO data Ctx = Ctx - { mbp :: !MiniBuildPlan + { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) + , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) , combinedMap :: !CombinedMap , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig @@ -170,18 +175,19 @@ instance HasEnvConfig Ctx where -- 3) It will only rebuild a local package if its files are dirty or -- some of its dependencies have changed. constructPlan :: forall env m. (StackM env m, HasEnvConfig env) - => MiniBuildPlan + => LoadedSnapshot -> BaseConfigOpts -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package + -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap + -> Bool -> m Plan -constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap = do +constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do $logDebug "Constructing the build plan" - getVersions0 <- getPackageVersionsIO + u <- askUnliftIO econfig <- view envConfigL let onWanted = void . addDep False . packageName . lpPackage @@ -189,8 +195,9 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 lf <- askLoggerIO + lp <- getLocalPackages ((), m, W efinals installExes dirtyReason deps warnings parents) <- - liftIO $ runRWST inner (ctx econfig getVersions0 lf) M.empty + liftIO $ runRWST inner (ctx econfig (unliftIO u . getPackageVersions) lf lp) M.empty mapM_ $logWarn (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) @@ -210,7 +217,7 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals - , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap + , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps , planInstallExes = if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 then installExes @@ -222,14 +229,14 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag $prettyError $ pprintExceptions errs stackYaml parents (wantedLocalPackages locals) throwM $ ConstructPlanFailed "Plan construction failed." where - ctx econfig getVersions0 lf = Ctx - { mbp = mbp0 + ctx econfig getVersions0 lf lp = Ctx + { ls = ls0 , baseConfigOpts = baseConfigOpts0 , loadPackage = loadPackage0 , combinedMap = combineMap sourceMap installedMap , toolToPackages = \(Cabal.Dependency name _) -> maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $ - Map.lookup (T.pack . packageNameString . fromCabalPackageName $ name) toolMap + Map.lookup (T.pack . packageNameString . fromCabalPackageName $ name) (toolMap lp) , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 @@ -238,10 +245,8 @@ constructPlan mbp0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackag , localNames = Set.fromList $ map (packageName . lpPackage) locals , logFunc = lf } - -- TODO Currently, this will only consider and install tools from the - -- snapshot. It will not automatically install build tools from extra-deps - -- or local packages. - toolMap = getToolMap mbp0 + + toolMap = getToolMap ls0 -- | State to be maintained during the calculation of local packages -- to unregister. @@ -260,8 +265,11 @@ mkUnregisterLocal :: Map PackageName Task -> [DumpPackage () () ()] -- ^ Local package database dump -> SourceMap + -> Bool + -- ^ If true, we're doing a special initialBuildSteps + -- build - don't unregister target packages. -> Map GhcPkgId (PackageIdentifier, Text) -mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap = +mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap initialBuildSteps = -- 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 @@ -304,9 +312,12 @@ mkUnregisterLocal tasks dirtyReason localDumpPkgs sourceMap = 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 + -- unregistered, unless it's a target and an initial-build-steps + -- build is being done. + | Just task <- Map.lookup name tasks + = if initialBuildSteps && taskIsTarget task && taskProvides task == ident + then Nothing + else 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" @@ -352,6 +363,7 @@ addFinal lp package isAllInOne = do , taskPresent = present , taskType = TTLocal lp , taskAllInOne = isAllInOne + , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) } tell mempty { wFinals = Map.singleton (packageName package) res } @@ -415,7 +427,8 @@ tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map Flag tellExecutablesUpstream name version loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- liftIO $ loadPackage ctx name version flags [] + let pir = PackageIdentifierRevision (PackageIdentifier name version) Nothing -- FIXME get the real CabalFileInfo + p <- liftIO $ loadPackage ctx (PLIndex pir) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -450,9 +463,9 @@ installPackage installPackage name ps minstalled = do ctx <- ask case ps of - PSUpstream version _ flags ghcOptions _ -> do + PSUpstream _ _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- liftIO $ loadPackage ctx name version flags ghcOptions + package <- liftIO $ loadPackage ctx pkgLoc flags ghcOptions resolveDepsAndInstall True ps package minstalled PSLocal lp -> case lpTestBench lp of @@ -550,8 +563,9 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL , taskType = case ps of PSLocal lp -> TTLocal lp - PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha + PSUpstream _ loc _ _ pkgLoc -> TTUpstream package (loc <> minLoc) pkgLoc , taskAllInOne = isAllInOne + , taskCachePkgSrc = toCachePkgSrc ps } -- Update response in the lib map. If it is an error, and there's @@ -664,7 +678,7 @@ checkDirtiness :: PackageSource -> M Bool checkDirtiness ps installed package present wanted = do ctx <- ask - moldOpts <- flip runLoggingT (logFunc ctx) $ tryGetFlagCache installed + moldOpts <- liftIO $ flip runLoggingT (logFunc ctx) $ flip runReaderT ctx $ tryGetFlagCache installed let configOpts = configureOpts (view envConfigL ctx) (baseConfigOpts ctx) @@ -684,6 +698,7 @@ checkDirtiness ps installed package present wanted = do shouldHaddockPackage buildOpts wanted (packageName package) || -- Disabling haddocks when old config had haddocks doesn't make dirty. maybe False configCacheHaddock moldOpts + , configCachePkgSrc = toCachePkgSrc ps } let mreason = case moldOpts of @@ -703,6 +718,10 @@ checkDirtiness ps installed package present wanted = do describeConfigDiff :: Config -> ConfigCache -> ConfigCache -> Maybe Text describeConfigDiff config old new + | configCachePkgSrc old /= configCachePkgSrc new = Just $ + "switching from " <> + pkgSrcName (configCachePkgSrc old) <> " to " <> + pkgSrcName (configCachePkgSrc new) | not (configCacheDeps new `Set.isSubsetOf` configCacheDeps old) = Just "dependencies changed" | not $ Set.null newComponents = Just $ "components added: " `T.append` T.intercalate ", " @@ -760,6 +779,9 @@ describeConfigDiff config old new newComponents = configCacheComponents new `Set.difference` configCacheComponents old + pkgSrcName (CacheSrcLocal fp) = T.pack fp + pkgSrcName CacheSrcUpstream = "upstream source" + psForceDirty :: PackageSource -> Bool psForceDirty (PSLocal lp) = lpForceDirty lp psForceDirty PSUpstream{} = False @@ -863,19 +885,21 @@ markAsDep name = tell mempty { wDeps = Set.singleton name } -- | Is the given package/version combo defined in the snapshot? inSnapshot :: PackageName -> Version -> M Bool inSnapshot name version = do - p <- asks mbp + p <- asks ls ls <- asks localNames return $ fromMaybe False $ do guard $ not $ name `Set.member` ls - mpi <- Map.lookup name (mbpPackages p) - return $ mpiVersion mpi == version + lpi <- Map.lookup name (lsPackages p) + return $ lpiVersion lpi == version data ConstructPlanException = DependencyCycleDetected [PackageName] | DependencyPlanFailures Package (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency)) | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all -- ^ Recommend adding to extra-deps, give a helpful version number? - deriving (Typeable, Eq, Show) + deriving (Typeable, Eq, Ord, Show) + +deriving instance Ord VersionRange -- | For display purposes only, Nothing if package not found type LatestApplicableVersion = Maybe Version @@ -885,7 +909,7 @@ data BadDependency = NotInBuildPlan | Couldn'tResolveItsDependencies Version | DependencyMismatch Version - deriving (Typeable, Eq, Show) + deriving (Typeable, Eq, Ord, Show) -- TODO: Consider intersecting version ranges for multiple deps on a -- package. This is why VersionRange is in the parent map. @@ -909,7 +933,7 @@ pprintExceptions exceptions stackYaml parentMap wanted = line <> "You may also want to try the 'stack solver' command" where - exceptions' = nub exceptions + exceptions' = nubOrd exceptions extras = Map.unions $ map getExtras exceptions' getExtras (DependencyCycleDetected _) = Map.empty @@ -923,11 +947,16 @@ pprintExceptions exceptions stackYaml parentMap wanted = pprintExtra (name, version) = fromString (concat ["- ", packageNameString name, "-", versionString version]) + allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' + toNotInBuildPlan (DependencyPlanFailures _ pDeps) = + map fst $ filter (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) $ Map.toList pDeps + toNotInBuildPlan _ = [] + pprintException (DependencyCycleDetected pNames) = Just $ "Dependency cycle detected in packages:" <> line <> indent 4 (encloseSep "[" "]" "," (map (errorRed . fromString . packageNameString) pNames)) - pprintException (DependencyPlanFailures pkg (Map.toList -> pDeps)) = - case mapMaybe pprintDep pDeps of + pprintException (DependencyPlanFailures pkg pDeps) = + case mapMaybe pprintDep (Map.toList pDeps) of [] -> Nothing depErrors -> Just $ "In the dependencies for" <+> pkgIdent <> @@ -944,9 +973,12 @@ pprintExceptions exceptions stackYaml parentMap wanted = [pkgIdent] where pkgIdent = displayCurrentPkgId (packageIdentifier pkg) - -- TODO: optionally show these? - -- Skip these because they are redundant with 'NotInBuildPlan' info. - pprintException (UnknownPackage _) = Nothing + -- Skip these when they are redundant with 'NotInBuildPlan' info. + pprintException (UnknownPackage name) + | name `Set.member` allNotInBuildPlan = Nothing + | name `HashSet.member` wiredInPackages = + Just $ "Can't build a package with same name as a wired-in-package:" <+> displayCurrentPkgName name + | otherwise = Just $ "Unknown package:" <+> displayCurrentPkgName name pprintFlags flags | Map.null flags = "" diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 70efae6626..657218f94b 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -17,22 +18,16 @@ module Stack.Build.Execute , ExecuteEnv , withExecuteEnv , withSingleContext + , ExcludeTHLoading(..) ) where import Control.Applicative import Control.Arrow ((&&&), second) import Control.Concurrent.Execute -import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM -import Control.Exception.Safe (catchIO) -import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Extra (anyM, (&&^)) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (liftBaseWith) -import Control.Monad.Trans.Resource import Crypto.Hash import Data.Attoparsec.Text hiding (try) import qualified Data.ByteArray as Mem (convert) @@ -51,6 +46,7 @@ import Data.IORef import Data.IORef.RunOnce (runOnce) import Data.List hiding (any) import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Maybe import Data.Maybe.Extra (forMaybeM) @@ -73,6 +69,7 @@ import Distribution.System (OS (Windows), import qualified Distribution.Text as C import Language.Haskell.TH as TH (location) import Path +import Path.CheckInstall import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile) import Path.IO hiding (findExecutable, makeAbsolute) import Prelude hiding (FilePath, writeFile, any) @@ -88,8 +85,10 @@ import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package import Stack.PackageDump +import Stack.PackageLocation import Stack.PrettyPrint import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId @@ -113,6 +112,12 @@ import System.Process.Run import System.Process.Internals (createProcess_) #endif +-- | Has an executable been built or not? +data ExecutableBuildStatus + = ExecutableBuilt + | ExecutableNotBuilt + deriving (Show, Eq, Ord) + -- | Fetch the packages necessary for a build, for example in combination with a dry run. preFetch :: (StackM env m, HasEnvConfig env) => Plan -> m () preFetch plan @@ -329,7 +334,7 @@ getSetupExe setupHs setupShimHs tmpdir = do return $ Just exePath -- | Execute a function that takes an 'ExecuteEnv'. -withExecuteEnv :: (StackM env m, HasEnvConfig env) +withExecuteEnv :: forall env m a. (StackM env m, HasEnvConfig env) => EnvOverride -> BuildOpts -> BuildOptsCLI @@ -340,10 +345,11 @@ withExecuteEnv :: (StackM env m, HasEnvConfig env) -> [DumpPackage () () ()] -- ^ local packages -> (ExecuteEnv m -> m a) -> m a -withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do - withSystemTempDir stackProgName $ \tmpdir -> do - configLock <- newMVar () - installLock <- newMVar () +withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = + withRunIO $ \run -> + withSystemTempDir stackProgName $ \tmpdir -> run $ do + configLock <- liftIO $ newMVar () + installLock <- liftIO $ newMVar () idMap <- liftIO $ newTVarIO Map.empty config <- view configL @@ -404,6 +410,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot where toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) + dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> m () dumpLogs chan totalWanted = do allLogs <- fmap reverse $ liftIO $ atomically drainChan case allLogs of @@ -424,6 +431,7 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot $logInfo $ T.pack $ "Log files have been written to: " ++ toFilePath (parent (snd firstLog)) where + drainChan :: STM [(Path Abs Dir, Path Abs File)] drainChan = do mx <- tryReadTChan chan case mx of @@ -432,9 +440,10 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot xs <- drainChan return $ x:xs + dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> m () dumpLogIfWarning (pkgDir, filepath) = do firstWarning <- runResourceT - $ CB.sourceFile (toFilePath filepath) + $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) $$ CT.decodeUtf8Lenient =$ CT.lines =$ CL.map stripCR @@ -442,15 +451,18 @@ withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshot =$ CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) + isWarning :: Text -> Bool isWarning t = ": Warning:" `T.isSuffixOf` t -- prior to GHC 8 || ": warning:" `T.isInfixOf` t -- GHC 8 is slightly different + dumpLog :: String -> (Path Abs Dir, Path Abs File) -> m () dumpLog msgSuffix (pkgDir, filepath) = do $logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] + compilerVer <- view actualCompilerVersionL runResourceT - $ CB.sourceFile (toFilePath filepath) + $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) $$ CT.decodeUtf8Lenient - =$ mungeBuildOutput True True pkgDir + =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer =$ CL.mapM_ $logInfo $logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" @@ -464,7 +476,7 @@ executePlan :: (StackM env m, HasEnvConfig env) -> [DumpPackage () () ()] -- ^ snapshot packages -> [DumpPackage () () ()] -- ^ local packages -> InstalledMap - -> Map PackageName SimpleTarget + -> Map PackageName Target -> Plan -> m () executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do @@ -511,7 +523,7 @@ copyExecutables exes = do case loc of Snap -> snapBin Local -> localBin - mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) + mfp <- liftIO $ forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext) >>= rejectMissingFile case mfp of Nothing -> do @@ -544,46 +556,8 @@ copyExecutables exes = do , T.pack destDir' , ":"] forM_ installed $ \exe -> $logInfo ("- " <> exe) + warnInstallSearchPathIssues destDir' installed - searchPath <- liftIO FP.getSearchPath - destDirIsInPATH <- liftIO $ - anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir') (D.canonicalizePath dir)) searchPath - if destDirIsInPATH - then forM_ installed $ \exe -> do - mexePath <- (liftIO . D.findExecutable . T.unpack) exe - case mexePath of - Just exePath -> do - exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath - unless (exeDir `FP.equalFilePath` destDir') $ do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: The \"" - , exe - , "\" executable found on the PATH environment variable is " - , T.pack exePath - , ", and not the version that was just installed." - ] - $logWarn $ T.concat - [ "This means that \"" - , exe - , "\" calls on the command line will not use this version." - ] - Nothing -> do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir' - , " is on the PATH but the \"" - , exe - , "\" executable that was just installed could not be found on the PATH." - ] - else do - $logWarn "" - $logWarn $ T.concat - [ "WARNING: Installation path " - , T.pack destDir' - , " not found on the PATH environment variable" - ] -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. @@ -599,7 +573,7 @@ windowsRenameCopy src dest = do -- | Perform the actual plan (internal) executePlan' :: (StackM env m, HasEnvConfig env) => InstalledMap - -> Map PackageName SimpleTarget + -> Map PackageName Target -> Plan -> ExecuteEnv m -> m () @@ -628,11 +602,7 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) - -- Yes, we're explicitly discarding result values, which in general would - -- be bad. monad-unlift does this all properly at the type system level, - -- but I don't want to pull it in for this one use case, when we know that - -- stack always using transformer stacks that are safe for this use case. - runInBase <- liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO let actions = concatMap (toActions installedMap' runInBase ee) $ Map.elems $ Map.mergeWithKey (\_ b f -> Just (Just b, Just f)) @@ -753,7 +723,7 @@ toActions installedMap runInBase ee (mbuild, mfinal) = getConfigCache :: (StackM env m, HasEnvConfig env) => ExecuteEnv m -> Task -> InstalledMap -> Bool -> Bool -> m (Map PackageIdentifier GhcPkgId, ConfigCache) -getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do +getConfigCache ExecuteEnv {..} task@Task {..} installedMap enableTest enableBench = do useExactConf <- view $ configL.to configAllowNewer let extra = -- We enable tests if the test suite dependencies are already @@ -772,9 +742,16 @@ getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = d idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of - Nothing -> error "singleBuild: invariant violated, missing package ID missing" - Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x) - Just (Executable _) -> Nothing + Nothing + -- Expect to instead find it in installedMap if it's + -- an initialBuildSteps target. + | boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task, + Just (_, installed) <- Map.lookup (packageIdentifierName ident) installedMap + -> installedToGhcPkgId ident installed + Just installed -> installedToGhcPkgId ident installed + _ -> error "singleBuild: invariant violated, missing package ID missing" + installedToGhcPkgId ident (Library ident' x) = assert (ident == ident') $ Just (ident, x) + installedToGhcPkgId _ (Executable _) = Nothing missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing TaskConfigOpts missing mkOpts = taskConfigOpts opts = mkOpts missing' @@ -790,6 +767,7 @@ getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = d TTUpstream{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) + , configCachePkgSrc = taskCachePkgSrc } allDepsMap = Map.union missing' taskPresent return (allDepsMap, cache) @@ -800,7 +778,7 @@ ensureConfig :: (StackM env m, HasEnvConfig env) -> Path Abs Dir -- ^ package directory -> ExecuteEnv m -> m () -- ^ announce - -> (Bool -> [String] -> m ()) -- ^ cabal + -> (ExcludeTHLoading -> [String] -> m ()) -- ^ cabal -> Path Abs File -- ^ .cabal file -> m Bool ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do @@ -839,7 +817,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do Just x -> return $ concat ["--with-", name, "=", toFilePath x] -- Configure cabal with arguments determined by -- Stack.Types.Build.configureOpts - cabal False $ "configure" : concat + cabal KeepTHLoading $ "configure" : concat [ concat exes , dirs , nodirs @@ -867,7 +845,7 @@ announceTask task x = $logInfo $ T.concat -- custom setup is built. -- -- * Provides the user a function with which run the Cabal process. -withSingleContext :: (StackM env m, HasEnvConfig env) +withSingleContext :: forall env m a. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext -> ExecuteEnv m @@ -877,14 +855,13 @@ withSingleContext :: (StackM env m, HasEnvConfig env) -- Nothing, just provide global and snapshot package -- databases. -> Maybe String - -> ( Package -- Package info - -> Path Abs File -- Cabal file path - -> Path Abs Dir -- Package root directory file path - -> (Bool -> [String] -> m ()) -- Function to run Cabal with args - -- The Bool indicates if it's a build step, so strip TH stuff - -> (Text -> m ()) -- An 'announce' function, for different build phases - -> Bool -- Whether output should be directed to the console - -> Maybe (Path Abs File, Handle) -- Log file + -> ( Package -- Package info + -> Path Abs File -- Cabal file path + -> Path Abs Dir -- Package root directory file path + -> (ExcludeTHLoading -> [String] -> m ()) -- Function to run Cabal with args + -> (Text -> m ()) -- An 'announce' function, for different build phases + -> Bool -- Whether output should be directed to the console + -> Maybe (Path Abs File, Handle) -- Log file -> m a) -> m a withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = @@ -907,18 +884,18 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md withPackage inner = case taskType of TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp) - TTUpstream package _ gitSHA1 -> do - mdist <- liftM Just distRelativeDir - m <- unpackPackageIdents eeTempDir mdist - $ Map.singleton taskProvides gitSHA1 - case Map.toList m of - [(ident, dir)] - | ident == taskProvides -> do - let name = packageIdentifierName taskProvides - cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" - let cabalfp = dir cabalfpRel - inner package cabalfp dir - _ -> error $ "withPackage: invariant violated: " ++ show m + TTUpstream package _ pkgLoc -> do + mdist <- distRelativeDir + menv <- getMinimalEnvOverride + root <- view projectRootL + dir <- case pkgLoc of + PLIndex pir -> unpackPackageIdent eeTempDir mdist pir + PLOther pkgLoc' -> resolveSinglePackageLocation menv root pkgLoc' + + let name = packageIdentifierName taskProvides + cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal" + let cabalfp = dir cabalfpRel + inner package cabalfp dir withLogFile pkgDir package inner | console = inner Nothing @@ -938,6 +915,12 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md (liftIO . hClose) $ \h -> inner (Just (logPath, h)) + withCabal + :: Package + -> Path Abs Dir + -> Maybe (Path Abs File, Handle) + -> ((ExcludeTHLoading -> [String] -> m ()) -> m a) + -> m a withCabal package pkgDir mlogFile inner = do config <- view configL @@ -979,6 +962,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md : ["-hide-all-packages"] ) + warnCustomNoDeps :: m () warnCustomNoDeps = case (taskType, packageBuildType package) of (TTLocal{}, Just C.Custom) -> do @@ -991,6 +975,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md $logWarn "Strongly recommend fixing the package's cabal file" _ -> return () + getPackageArgs :: Path Abs Dir -> m [String] getPackageArgs setupDir = case (packageSetupDeps package, mdeps) of -- The package is using the Cabal custom-setup @@ -1070,17 +1055,20 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)]) setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args - runExe exeName fullArgs = - runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + + runExe :: Path Abs File -> [String] -> m () + runExe exeName fullArgs = do + compilerVer <- view actualCompilerVersionL + runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do bss <- case mlogFile of Nothing -> return [] Just (logFile, h) -> do liftIO $ hClose h runResourceT - $ CB.sourceFile (toFilePath logFile) + $ transPipe liftResourceT (CB.sourceFile (toFilePath logFile)) =$= CT.decodeUtf8Lenient - $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir + $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer =$ CL.consume throwM $ CabalExitedUnsuccessfully ec @@ -1090,19 +1078,28 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md (fmap fst mlogFile) bss where - runAndOutput = case mlogFile of + runAndOutput :: CompilerVersion 'CVActual -> m () + runAndOutput compilerVer = case mlogFile of Just (_, h) -> sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h Nothing -> void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs - (outputSink False LevelWarn) - (outputSink stripTHLoading LevelInfo) - outputSink excludeTH level = + (outputSink KeepTHLoading LevelWarn compilerVer) + (outputSink stripTHLoading LevelInfo compilerVer) + outputSink + :: ExcludeTHLoading + -> LogLevel + -> CompilerVersion 'CVActual + -> Sink S.ByteString IO () + outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient - =$ mungeBuildOutput excludeTH makeAbsolute pkgDir + =$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level) -- If users want control, we should add a config option for this - makeAbsolute = stripTHLoading + makeAbsolute :: ConvertPathsToAbsolute + makeAbsolute = case stripTHLoading of + ExcludeTHLoading -> ConvertPathsToAbsolute + KeepTHLoading -> KeepPathsAsIs wc <- view $ actualCompilerVersionL.whichCompilerL exeName <- case (esetupexehs, wc) of @@ -1158,7 +1155,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md -- local install directory. Note that this is literally invoking Cabal -- with @copy@, and not the copying done by @stack install@ - that is -- handled by 'copyExecutables'. -singleBuild :: (StackM env m, HasEnvConfig env) +singleBuild :: forall env m. (StackM env m, HasEnvConfig env) => (m () -> IO ()) -> ActionContext -> ExecuteEnv m @@ -1191,7 +1188,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in enableTests = buildingFinals && any isCTest (taskComponents task) enableBenchmarks = buildingFinals && any isCBench (taskComponents task) - annSuffix = if result == "" then "" else " (" <> result <> ")" + annSuffix executableBuildStatuses = if result == "" then "" else " (" <> result <> ")" where result = T.intercalate " + " $ concat [ ["lib" | taskAllInOne && hasLib] @@ -1200,7 +1197,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in , ["bench" | enableBenchmarks] ] (hasLib, hasExe) = case taskType of - TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild lp))) + TTLocal lp -> (packageHasLibrary (lpPackage lp), not (Set.null (exesToBuild executableBuildStatuses lp))) -- This isn't true, but we don't want to have this info for -- upstream deps. TTUpstream{} -> (False, False) @@ -1291,30 +1288,46 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do - _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix)) cabal cabalfp + executableBuildStatuses <- getExecutableBuildStatuses package pkgDir + when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) + ($logInfo + ("Building all executables for `" <> packageNameText (packageName package) <> + "' once. After a successful build of all of them, only specified executables will be rebuilt.")) + + _neededConfig <- ensureConfig cache pkgDir ee (announce ("configure" <> annSuffix executableBuildStatuses)) cabal cabalfp + + let installedMapHasThisPkg :: Bool + installedMapHasThisPkg = + case Map.lookup (packageName package) installedMap of + Just (_, Library ident _) -> ident == taskProvides + Just (_, Executable _) -> True + _ -> False case ( boptsCLIOnlyConfigure eeBuildOptsCLI - , boptsCLIInitialBuildSteps eeBuildOptsCLI && isTarget - , acDownstream) of + , boptsCLIInitialBuildSteps eeBuildOptsCLI && taskIsTarget task) of -- A full build is done if there are downstream actions, -- because their configure step will require that this -- package is built. See -- https://github.com/commercialhaskell/stack/issues/2787 - (True, _, []) -> return Nothing - (_, True, []) -> do - initialBuildSteps cabal announce + (True, _) | null acDownstream -> return Nothing + (_, True) | null acDownstream || installedMapHasThisPkg -> do + initialBuildSteps executableBuildStatuses cabal announce return Nothing - _ -> liftM Just $ realBuild cache package pkgDir cabal announce - - isTarget = case taskType of - TTLocal lp -> lpWanted lp - _ -> False - - initialBuildSteps cabal announce = do - () <- announce ("initial-build-steps" <> annSuffix) - cabal False ["repl", "stack-initial-build-steps"] - - realBuild cache package pkgDir cabal announce = do + _ -> liftM Just $ realBuild cache package pkgDir cabal announce executableBuildStatuses + + initialBuildSteps executableBuildStatuses cabal announce = do + () <- announce ("initial-build-steps" <> annSuffix executableBuildStatuses) + cabal KeepTHLoading ["repl", "stack-initial-build-steps"] + + realBuild + :: ConfigCache + -> Package + -> Path Abs Dir + -> (ExcludeTHLoading -> [String] -> m ()) + -> (Text -> m ()) + -> Map Text ExecutableBuildStatus + -> m Installed + realBuild cache package pkgDir cabal announce executableBuildStatuses = do wc <- view $ actualCompilerVersionL.whichCompilerL markExeNotInstalled (taskLocation task) taskProvides @@ -1350,15 +1363,18 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in line <> line <> "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems." - () <- announce ("build" <> annSuffix) + () <- announce ("build" <> annSuffix executableBuildStatuses) config <- view configL extraOpts <- extraBuildOptions wc eeBuildOpts - cabal (configHideTHLoading config) (("build" :) $ (++ extraOpts) $ + let stripTHLoading + | configHideTHLoading config = ExcludeTHLoading + | otherwise = KeepTHLoading + cabal stripTHLoading (("build" :) $ (++ extraOpts) $ case (taskType, taskAllInOne, isFinalBuild) of (_, True, True) -> error "Invariant violated: cannot have an all-in-one build that also has a final build step." - (TTLocal lp, False, False) -> primaryComponentOptions lp + (TTLocal lp, False, False) -> primaryComponentOptions executableBuildStatuses lp (TTLocal lp, False, True) -> finalComponentOptions lp - (TTLocal lp, True, False) -> primaryComponentOptions lp ++ finalComponentOptions lp + (TTLocal lp, True, False) -> primaryComponentOptions executableBuildStatuses lp ++ finalComponentOptions lp (TTUpstream{}, _, _) -> []) `catch` \ex -> case ex of CabalExitedUnsuccessfully{} -> postBuildCheck False >> throwM ex @@ -1381,22 +1397,23 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") return ["--hyperlink-source" | hscolourExists] - cabal False (concat [ ["haddock", "--html", "--html-location=../$pkg-$version/"] - , sourceFlag - , ["--internal" | boptsHaddockInternal eeBuildOpts] - , [ "--haddock-option=" <> opt - | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] - ]) + cabal KeepTHLoading $ concat + [ ["haddock", "--html", "--html-location=../$pkg-$version/"] + , sourceFlag + , ["--internal" | boptsHaddockInternal eeBuildOpts] + , [ "--haddock-option=" <> opt + | opt <- hoAdditionalArgs (boptsHaddockOpts eeBuildOpts) ] + ] let shouldCopy = not isFinalBuild && (packageHasLibrary package || not (Set.null (packageExes package))) when shouldCopy $ withMVar eeInstallLock $ \() -> do announce "copy/register" - eres <- try $ cabal False ["copy"] + eres <- try $ cabal KeepTHLoading ["copy"] case eres of Left err@CabalExitedUnsuccessfully{} -> throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err) _ -> return () - when (packageHasLibrary package) $ cabal False ["register"] + when (packageHasLibrary package) $ cabal KeepTHLoading ["register"] let (installedPkgDb, installedDumpPkgsTVar) = case taskLocation task of @@ -1425,12 +1442,15 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in Local -> return () case taskType of - -- For upstream packages, pkgDir is in the tmp directory. We - -- eagerly delete it if no other tasks require it, to reduce - -- space usage in tmp (#3018). - TTUpstream{} -> do - let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) - when (null remaining) $ removeDirRecur pkgDir + -- For upstream packages from a package index, pkgDir is in the tmp + -- directory. We eagerly delete it if no other tasks require it, to + -- reduce space usage in tmp (#3018). + TTUpstream _ _ loc -> + case loc of + PLIndex _ -> do + let remaining = filter (\(ActionId x _) -> x == taskProvides) (Set.toList acRemaining) + when (null remaining) $ removeDirRecur pkgDir + _ -> return () _ -> return () return mpkgid @@ -1444,6 +1464,56 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in return $ Just (dpGhcPkgId dp) _ -> error "singleBuild: invariant violated: multiple results when describing installed package" +-- | Get the build status of all the package executables. Do so by +-- testing whether their expected output file exists, e.g. +-- +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe +-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir) +getExecutableBuildStatuses + :: (StackM env m, HasEnvConfig env) + => Package -> Path Abs Dir -> m (Map Text ExecutableBuildStatus) +getExecutableBuildStatuses package pkgDir = do + compiler <- view $ actualCompilerVersionL.whichCompilerL + distDir <- distDirFromDir pkgDir + platform <- view platformL + fmap + M.fromList + (mapM (checkExeStatus compiler platform distDir) (Set.toList (packageExes package))) + +-- | Check whether the given executable is defined in the given dist directory. +checkExeStatus + :: (MonadLogger m, MonadIO m, MonadThrow m) + => WhichCompiler + -> Platform + -> Path b Dir + -> Text + -> m (Text, ExecutableBuildStatus) +checkExeStatus compiler platform distDir name = do + exename <- parseRelDir (T.unpack name) + exists <- checkPath (distDir $(mkRelDir "build") exename) + pure + ( name + , if exists + then ExecutableBuilt + else ExecutableNotBuilt) + where + checkPath base = + case compiler of + Ghcjs -> do + dir <- parseRelDir (file ++ ".jsexe") + doesDirExist (base dir) + _ -> + case platform of + Platform _ Windows -> do + fileandext <- parseRelFile (file ++ ".exe") + doesFileExist (base fileandext) + _ -> do + fileandext <- parseRelFile file + doesFileExist (base fileandext) + where + file = T.unpack name + -- | Check if any unlisted files have been found, and add them to the build cache. checkForUnlistedFiles :: (StackM env m, HasEnvConfig env) => TaskType -> ModTime -> Path Abs Dir -> m [PackageWarning] checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do @@ -1542,7 +1612,7 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do tixexists <- doesFileExist tixPath when tixexists $ $logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath)) - ignoringAbsence (removeFile tixPath) + liftIO $ ignoringAbsence (removeFile tixPath) let args = toAdditionalArgs topts argsDisplay = case args of @@ -1639,36 +1709,59 @@ singleBench runInBase beopts benchesToRun ac ee task installedMap = do return True when toRun $ do - announce "benchmarks" - cabal False ("bench" : args) + announce "benchmarks" + cabal KeepTHLoading ("bench" : args) + +data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading +data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs -- | Strip Template Haskell "Loading package" lines and making paths absolute. -mungeBuildOutput :: (MonadIO m, MonadCatch m, MonadBaseControl IO m) - => Bool -- ^ exclude TH loading? - -> Bool -- ^ convert paths to absolute? - -> Path Abs Dir -- ^ package's root directory +mungeBuildOutput :: forall m. (MonadUnliftIO m, MonadThrow m) + => ExcludeTHLoading -- ^ exclude TH loading? + -> ConvertPathsToAbsolute -- ^ convert paths to absolute? + -> Path Abs Dir -- ^ package's root directory + -> CompilerVersion 'CVActual -- ^ compiler we're building with -> ConduitM Text Text m () -mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ +mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines =$ CL.map stripCR =$ CL.filter (not . isTHLoading) - =$ CL.mapM toAbsolutePath + =$ filterLinkerWarnings + =$ toAbsolute where -- | Is this line a Template Haskell "Loading package" line -- ByteString isTHLoading :: Text -> Bool - isTHLoading _ | not excludeTHLoading = False - isTHLoading bs = - "Loading package " `T.isPrefixOf` bs && - ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + isTHLoading = case excludeTHLoading of + KeepTHLoading -> const False + ExcludeTHLoading -> \bs -> + "Loading package " `T.isPrefixOf` bs && + ("done." `T.isSuffixOf` bs || "done.\r" `T.isSuffixOf` bs) + + filterLinkerWarnings :: ConduitM Text Text m () + filterLinkerWarnings + -- Check for ghc 7.8 since it's the only one prone to producing + -- linker warnings on Windows x64 + | getGhcVersion compilerVer >= $(mkVersion "7.8") = doNothing + | otherwise = CL.filter (not . isLinkerWarning) + + isLinkerWarning :: Text -> Bool + isLinkerWarning str = + ("ghc.exe: warning:" `T.isPrefixOf` str || "ghc.EXE: warning:" `T.isPrefixOf` str) && + "is linked instead of __imp_" `T.isInfixOf` str -- | Convert GHC error lines with file paths to have absolute file paths - toAbsolutePath bs | not makeAbsolute = return bs + toAbsolute :: ConduitM Text Text m () + toAbsolute = case makeAbsolute of + KeepPathsAsIs -> doNothing + ConvertPathsToAbsolute -> CL.mapM toAbsolutePath + + toAbsolutePath :: Text -> m Text toAbsolutePath bs = do let (x, y) = T.break (== ':') bs mabs <- if isValidSuffix y - then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ + then liftIO $ liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $ forgivingAbsence (resolveFile pkgDir (T.unpack $ T.dropWhile isSpace x)) `catch` \(_ :: PathParseException) -> return Nothing else return Nothing @@ -1676,6 +1769,9 @@ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir = void $ Nothing -> return bs Just fp -> return $ fp `T.append` y + doNothing :: ConduitM Text Text m () + doNothing = awaitForever yield + -- | Match the error location format at the end of lines isValidSuffix = isRight . parseOnly lineCol lineCol = char ':' @@ -1719,27 +1815,36 @@ extraBuildOptions wc bopts = do return [optsFlag, ddumpOpts] -- Library and executable build components. -primaryComponentOptions :: LocalPackage -> [String] -primaryComponentOptions lp = ["lib:" ++ packageNameString (packageName (lpPackage lp)) +primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String] +primaryComponentOptions executableBuildStatuses lp = ["lib:" ++ packageNameString (packageName (lpPackage lp)) -- TODO: get this information from target parsing instead, -- which will allow users to turn off library building if -- desired | packageHasLibrary (lpPackage lp)] ++ - map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild lp) - -exesToBuild :: LocalPackage -> Set Text -exesToBuild lp = packageExes (lpPackage lp) - -- NOTE: Ideally we'd do something like the following code, allowing - -- the user to control which executables get built. However, due to - -- https://github.com/haskell/cabal/issues/2780 we must build all - -- exes... - -- - -- if lpWanted lp - -- then exeComponents (lpComponents lp) - -- -- Build all executables in the event that no - -- -- specific list is provided (as happens with - -- -- extra-deps). - -- else packageExes (lpPackage lp) + map (T.unpack . T.append "exe:") (Set.toList $ exesToBuild executableBuildStatuses lp) + +-- | History of this function: +-- +-- * Normally it would do either all executables or if the user +-- specified requested components, just build them. Afterwards, due +-- to this Cabal bug , +-- we had to make Stack build all executables every time. +-- +-- * In this +-- was flagged up as very undesirable behavior on a large project, +-- hence the behavior below that we build all executables once +-- (modulo success), and thereafter pay attention to user-wanted +-- components. +-- +exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text +exesToBuild executableBuildStatuses lp = + if cabalIsSatisfied executableBuildStatuses && lpWanted lp + then exeComponents (lpComponents lp) + else packageExes (lpPackage lp) + +-- | Do the current executables satisfy Cabal's bugged out requirements? +cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool +cabalIsSatisfied = all (== ExecutableBuilt) . M.elems -- Test-suite and benchmark build components. finalComponentOptions :: LocalPackage -> [String] diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index 39404c9d47..2aa6df54a6 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -16,12 +16,9 @@ module Stack.Build.Haddock , shouldHaddockDeps ) where -import Control.Exception (tryJust, onException) import Control.Monad -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Resource import qualified Data.Foldable as F import Data.Function import qualified Data.HashSet as HS @@ -119,7 +116,7 @@ shouldHaddockDeps bopts = fromMaybe (boptsHaddock bopts) (boptsHaddockDeps bopts -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -145,7 +142,7 @@ generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -190,7 +187,7 @@ generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs loca -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> BaseConfigOpts @@ -209,7 +206,7 @@ generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (MonadIO m, MonadCatch m, MonadLogger m, MonadBaseControl IO m) + :: (MonadUnliftIO m, MonadLogger m) => Text -> EnvOverride -> WhichCompiler diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 747dd45e7d..b9e1a7dfc8 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -32,7 +32,6 @@ import Path import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache import Stack.Constants -import Stack.GhcPkg import Stack.PackageDump import Stack.Types.Build import Stack.Types.Compiler @@ -44,6 +43,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.StackT import Stack.Types.Version +import System.Process.Read (EnvOverride) -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 3b508f6c66..33e82aac19 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} @@ -12,25 +9,17 @@ module Stack.Build.Source ( loadSourceMap , loadSourceMapFull , SourceMap - , PackageSource (..) , getLocalFlags , getGhcOptions - , getLocalPackageViews - , parseTargetsFromBuildOpts - , parseTargetsFromBuildOptsWith , addUnlistedToBuildCache , getDefaultPackageConfig - , getPackageConfig ) where import Control.Applicative import Control.Arrow ((&&&)) -import Control.Exception (assert, catch) import Control.Monad hiding (sequence) -import Control.Monad.IO.Class -import Control.Monad.Logger +import Control.Monad.IO.Unlift import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Resource import Crypto.Hash (Digest, SHA256(..)) import Crypto.Hash.Conduit (sinkHash) import qualified Data.ByteArray as Mem (convert) @@ -38,7 +27,6 @@ import qualified Data.ByteString as S import Data.Conduit (($$), ZipSink (..)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -import Data.Either import Data.Function import qualified Data.HashSet as HashSet import Data.List @@ -50,30 +38,21 @@ import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) -import qualified Data.Text as T import Data.Traversable (sequence) -import Distribution.Package (pkgName, pkgVersion) -import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) -import qualified Distribution.PackageDescription as C import Path -import Path.IO import Prelude hiding (sequence) import Stack.Build.Cache import Stack.Build.Target -import Stack.BuildPlan (shadowMiniBuildPlan) import Stack.Config (getLocalPackages) import Stack.Constants (wiredInPackages) import Stack.Package -import Stack.PackageIndex (getPackageVersions) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.Package import Stack.Types.PackageName -import Stack.Types.Resolver import Stack.Types.StackT -import Stack.Types.Version import qualified System.Directory as D import System.FilePath (takeFileName) import System.IO (withBinaryFile, IOMode (ReadMode)) @@ -88,14 +67,14 @@ loadSourceMap :: (StackM env m, HasEnvConfig env) , SourceMap ) loadSourceMap needTargets boptsCli = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull needTargets boptsCli + (_, _, locals, _, sourceMap) <- loadSourceMapFull needTargets boptsCli return (locals, sourceMap) -- | Given the build commandline options, does the following: -- -- * Parses the build targets. -- --- * Loads the 'MiniBuildPlan' from the resolver, with extra-deps +-- * Loads the 'LoadedSnapshot' from the resolver, with extra-deps -- shadowing any packages that should be built locally. -- -- * Loads up the 'LocalPackage' info. @@ -105,96 +84,43 @@ loadSourceMap needTargets boptsCli = do loadSourceMapFull :: (StackM env m, HasEnvConfig env) => NeedTargets -> BuildOptsCLI - -> m ( Map PackageName SimpleTarget - , MiniBuildPlan + -> m ( Map PackageName Target + , LoadedSnapshot , [LocalPackage] - , Set PackageName -- non-local targets - , Map PackageName Version -- extra-deps from configuration and cli + , Set PackageName -- non-project targets , SourceMap ) loadSourceMapFull 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 - -- that are not in the snapshot. - extraDeps0 <- extendExtraDeps - (bcExtraDeps bconfig) - cliExtraDeps - (Map.keysSet $ Map.filter (== STUnknown) targets) - - locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList rawLocals - checkFlagsUsed boptsCli locals extraDeps0 (mbpPackages mbp0) + (ls, localDeps, targets) <- parseTargets needTargets boptsCli + lp <- getLocalPackages + locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList $ lpProject lp + checkFlagsUsed boptsCli locals localDeps (lsPackages ls) checkComponentsBuildable locals - let - -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; - -- here we combine them into nonLocalTargets. This is one of the - -- return values of this function. - nonLocalTargets :: Set PackageName - nonLocalTargets = - Map.keysSet $ Map.filter (not . isLocal) targets - where - isLocal (STLocalComps _) = True - isLocal STLocalAll = True - isLocal STUnknown = False - isLocal STNonLocal = False - - shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0 - - -- Ignores all packages in the MiniBuildPlan that depend on any - -- local packages or extra-deps. All packages that have - -- transitive dependenceis on these packages are treated as - -- extra-deps (extraDeps1). - (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed + -- TODO for extra sanity, confirm that the targets we threw away are all TargetAll + let nonProjectTargets = Map.keysSet targets `Set.difference` Map.keysSet (lpProject lp) - -- Combine the extra-deps with the ones implicitly shadowed. - extraDeps2 = Map.union - (Map.map (\v -> (v, Map.empty, [])) extraDeps0) - (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1) - - -- Add flag and ghc-option settings from the config file / cli - extraDeps3 = Map.mapWithKey - (\n (v, flags0, ghcOptions0) -> - let flags = - case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli - , Map.lookup Nothing $ boptsCLIFlags boptsCli - , Map.lookup n $ unPackageFlags $ bcFlags bconfig - ) of - -- Didn't have any flag overrides, fall back to the flags - -- defined in the snapshot. - (Nothing, Nothing, Nothing) -> flags0 - -- Either command line flag for this package, general - -- command line flag, or flag in stack.yaml is defined. - -- Take all of those and ignore the snapshot flags. - (x, y, z) -> Map.unions - [ fromMaybe Map.empty x - , fromMaybe Map.empty y - , fromMaybe Map.empty z - ] - ghcOptions = - ghcOptions0 ++ - getGhcOptions bconfig boptsCli n False False - -- currently have no ability for extra-deps to specify their - -- cabal file hashes - in PSUpstream v Local flags ghcOptions Nothing) - extraDeps2 - - -- Combine the local packages, extra-deps, and MiniBuildPlan into + -- Combine the local packages, extra-deps, and LoadedSnapshot into -- one unified source map. let sourceMap = Map.unions - [ Map.fromList $ flip map locals $ \lp -> - let p = lpPackage lp - in (packageName p, PSLocal lp) - , extraDeps3 - , flip Map.mapWithKey (mbpPackages mbp) $ \n mpi -> + [ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSLocal lp')) locals + , flip Map.mapWithKey localDeps $ \n lpi -> let configOpts = getGhcOptions bconfig boptsCli n False False - in PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi ++ configOpts) (mpiGitSHA1 mpi) + in PSUpstream (lpiVersion lpi) Local (lpiFlags lpi) (lpiGhcOptions lpi ++ configOpts) (lpiLocation lpi) + , flip Map.mapWithKey (lsPackages ls) $ \n lpi -> + let configOpts = getGhcOptions bconfig boptsCli n False False + in PSUpstream (lpiVersion lpi) Snap (lpiFlags lpi) (lpiGhcOptions lpi ++ configOpts) (lpiLocation lpi) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - return (targets, mbp, locals, nonLocalTargets, extraDeps0, sourceMap) + return + ( targets + , ls + , locals + , nonProjectTargets + , sourceMap + ) -- | All flags for a local package. getLocalFlags @@ -205,7 +131,7 @@ getLocalFlags getLocalFlags bconfig boptsCli name = Map.unions [ Map.findWithDefault Map.empty (Just name) cliFlags , Map.findWithDefault Map.empty Nothing cliFlags - , Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig)) + , Map.findWithDefault Map.empty name (bcFlags bconfig) ] where cliFlags = boptsCLIFlags boptsCli @@ -235,137 +161,6 @@ getGhcOptions bconfig boptsCli name isTarget isLocal = concat AGOLocals -> isLocal AGOEverything -> True --- | Use the build options and environment to parse targets. --- --- If the local packages views are already known, use 'parseTargetsFromBuildOptsWith' --- instead. --- --- Along with the 'Map' of targets, this yields the loaded --- 'MiniBuildPlan' for the resolver, as well as a Map of extra-deps --- derived from the commandline. These extra-deps targets come from when --- the user specifies a particular package version on the commonadline, --- or when a flag is specified for a snapshot package. -parseTargetsFromBuildOpts - :: (StackM env m, HasEnvConfig env) - => NeedTargets - -> BuildOptsCLI - -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) -parseTargetsFromBuildOpts needTargets boptscli = do - rawLocals <- getLocalPackageViews - parseTargetsFromBuildOptsWith rawLocals needTargets boptscli - -parseTargetsFromBuildOptsWith - :: (StackM env m, HasEnvConfig env) - => Map PackageName (LocalPackageView, GenericPackageDescription) - -- ^ Local package views - -> NeedTargets - -> BuildOptsCLI - -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) -parseTargetsFromBuildOptsWith rawLocals needTargets boptscli = do - $logDebug "Parsing the targets" - 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 <- view actualCompilerVersionL - return MiniBuildPlan - { mbpCompilerVersion = version - , mbpPackages = Map.empty - } - _ -> return (bcWantedMiniBuildPlan bconfig) - workingDir <- getCurrentDir - - let snapshot = mpiVersion <$> mbpPackages mbp0 - flagExtraDeps <- convertSnapshotToExtra - snapshot - (bcExtraDeps bconfig) - rawLocals - (catMaybes $ Map.keys $ boptsCLIFlags boptscli) - - (cliExtraDeps, targets) <- - parseTargets - needTargets - (bcImplicitGlobal bconfig) - snapshot - (flagExtraDeps <> bcExtraDeps bconfig) - (fst <$> rawLocals) - workingDir - (boptsCLITargets boptscli) - return (mbp0, cliExtraDeps <> flagExtraDeps, targets) - --- | For every package in the snapshot which is referenced by a flag, give the --- user a warning and then add it to extra-deps. -convertSnapshotToExtra - :: MonadLogger m - => Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra-deps - -> Map PackageName a -- ^ locals - -> [PackageName] -- ^ packages referenced by a flag - -> m (Map PackageName Version) -convertSnapshotToExtra snapshot extra0 locals = go Map.empty - where - go !extra [] = return extra - go extra (flag:flags) - | Just _ <- Map.lookup flag extra0 = go extra flags - | flag `Map.member` locals = go extra flags - | otherwise = case Map.lookup flag snapshot of - Nothing -> go extra flags - Just version -> do - $logWarn $ T.concat - [ "- Implicitly adding " - , T.pack $ packageNameString flag - , " to extra-deps based on command line flag" - ] - go (Map.insert flag version extra) flags - --- | Parse out the local package views for the current project -getLocalPackageViews :: (StackM env m, HasEnvConfig env) - => m (Map PackageName (LocalPackageView, GenericPackageDescription)) -getLocalPackageViews = do - $logDebug "Parsing the cabal files of the local packages" - packages <- getLocalPackages - locals <- forM (Map.toList packages) $ \(dir, treatLikeExtraDep) -> do - cabalfp <- findOrGenerateCabalFile dir - (warnings,gpkg) <- readPackageUnresolved cabalfp - mapM_ (printCabalFileWarning cabalfp) warnings - let cabalID = package $ packageDescription gpkg - name = fromCabalPackageName $ pkgName cabalID - checkCabalFileName name cabalfp - let lpv = LocalPackageView - { lpvVersion = fromCabalVersion $ pkgVersion cabalID - , lpvRoot = dir - , lpvCabalFP = cabalfp - , lpvExtraDep = treatLikeExtraDep - , lpvComponents = getNamedComponents gpkg - } - return (name, (lpv, gpkg)) - checkDuplicateNames locals - return $ Map.fromList locals - where - getNamedComponents gpkg = Set.fromList $ concat - [ maybe [] (const [CLib]) (C.condLibrary gpkg) - , go CExe C.condExecutables - , go CTest C.condTestSuites - , go CBench C.condBenchmarks - ] - where - go wrapper f = map (wrapper . T.pack . fst) $ f gpkg - --- | Check if there are any duplicate package names and, if so, throw an --- exception. -checkDuplicateNames :: MonadThrow m => [(PackageName, (LocalPackageView, gpd))] -> m () -checkDuplicateNames locals = - case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map toPair locals of - [] -> return () - x -> throwM $ DuplicateLocalPackageNames x - where - toPair (pn, (lpv, _)) = (pn, [lpvRoot lpv]) - hasMultiples (_, _:_:_) = True - hasMultiples _ = False - splitComponents :: [NamedComponent] -> (Set Text, Set Text, Set Text) splitComponents = @@ -382,27 +177,25 @@ splitComponents = loadLocalPackage :: forall m env. (StackM env m, HasEnvConfig env) => BuildOptsCLI - -> Map PackageName SimpleTarget - -> (PackageName, (LocalPackageView, GenericPackageDescription)) + -> Map PackageName Target + -> (PackageName, LocalPackageView) -> m LocalPackage -loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do +loadLocalPackage boptsCli targets (name, lpv) = do let mtarget = Map.lookup name targets config <- getPackageConfig boptsCli name (isJust mtarget) True bopts <- view buildOptsL let (exes, tests, benches) = case mtarget of - Just (STLocalComps comps) -> splitComponents $ Set.toList comps - Just STLocalAll -> + Just (TargetComps comps) -> splitComponents $ Set.toList comps + Just (TargetAll packageType) -> assert (packageType == ProjectPackage) ( packageExes pkg - , if boptsTests bopts && not (lpvExtraDep lpv) + , if boptsTests bopts then Map.keysSet (packageTests pkg) else Set.empty - , if boptsBenchmarks bopts && not (lpvExtraDep lpv) + , if boptsBenchmarks bopts then packageBenchmarks pkg else Set.empty ) - Just STNonLocal -> assert False mempty - Just STUnknown -> assert False mempty Nothing -> mempty toComponents e t b = Set.unions @@ -439,6 +232,7 @@ loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do -- This allows us to do an optimization where these are passed -- if the deps are present. This can avoid doing later -- unnecessary reconfigures. + gpkg = lpvGPD lpv pkg = resolvePackage config gpkg btpkg | Set.null tests && Set.null benches = Nothing @@ -488,7 +282,7 @@ loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOptsCLI -> [LocalPackage] - -> Map PackageName extraDeps -- ^ extra deps + -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ local deps -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () checkFlagsUsed boptsCli lps extraDeps snapshot = do @@ -497,21 +291,21 @@ checkFlagsUsed boptsCli lps extraDeps snapshot = do -- Check if flags specified in stack.yaml and the command line are -- used, see https://github.com/commercialhaskell/stack/issues/617 let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli] - ++ map (, FSStackYaml) (Map.toList $ unPackageFlags $ bcFlags bconfig) + ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig) localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps checkFlagUsed ((name, userFlags), source) = case Map.lookup name localNameMap of -- Package is not available locally Nothing -> - case Map.lookup name extraDeps of + if Map.member name extraDeps + -- We don't check for flag presence for extra deps + then Nothing -- Also not in extra-deps, it's an error - Nothing -> + else case Map.lookup name snapshot of Nothing -> Just $ UFNoPackage source name Just _ -> Just $ UFSnapshot name - -- We don't check for flag presence for extra deps - Just _ -> Nothing -- Package exists locally, let's check if the flags are defined Just pkg -> let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg) @@ -528,41 +322,6 @@ checkFlagsUsed boptsCli lps extraDeps snapshot = do $ InvalidFlagSpecification $ Set.fromList unusedFlags --- | Add in necessary packages to extra dependencies --- --- Originally part of https://github.com/commercialhaskell/stack/issues/272, --- this was then superseded by --- https://github.com/commercialhaskell/stack/issues/651 -extendExtraDeps - :: (StackM env m, HasBuildConfig env) - => Map PackageName Version -- ^ original extra deps - -> Map PackageName Version -- ^ package identifiers from the command line - -> Set PackageName -- ^ all packages added on the command line - -> m (Map PackageName Version) -- ^ new extradeps -extendExtraDeps extraDeps0 cliExtraDeps unknowns = do - (errs, unknowns') <- fmap partitionEithers $ mapM addUnknown $ Set.toList unknowns - case errs of - [] -> return $ Map.unions $ extraDeps1 : unknowns' - _ -> do - bconfig <- view buildConfigL - throwM $ UnknownTargets - (Set.fromList errs) - Map.empty -- TODO check the cliExtraDeps for presence in index - (bcStackYaml bconfig) - where - extraDeps1 = Map.union extraDeps0 cliExtraDeps - addUnknown pn = do - case Map.lookup pn extraDeps1 of - Just _ -> return (Right Map.empty) - Nothing -> do - mlatestVersion <- getLatestVersion pn - case mlatestVersion of - Just v -> return (Right $ Map.singleton pn v) - Nothing -> return (Left pn) - getLatestVersion pn = do - vs <- getPackageVersions pn - return (fmap fst (Set.maxView vs)) - -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values. checkBuildCache :: forall m. (MonadIO m) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 72a87189ea..eebb895152 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -2,55 +2,138 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | Parsing command line targets +-- +-- There are two relevant data sources for performing this parsing: +-- the project configuration, and command line arguments. Project +-- configurations includes the resolver (defining a LoadedSnapshot of +-- global and snapshot packages), local dependencies, and project +-- packages. It also defines local flag overrides. +-- +-- The command line arguments specify both additional local flag +-- overrides and targets in their raw form. +-- +-- Flags are simple: we just combine CLI flags with config flags and +-- make one big map of flags, preferring CLI flags when present. +-- +-- Raw targets can be a package name, a package name with component, +-- just a component, or a package name and version number. We first +-- must resolve these raw targets into both simple targets and +-- additional dependencies. This works as follows: +-- +-- * If a component is specified, find a unique project package which +-- defines that component, and convert it into a name+component +-- target. +-- +-- * Ensure that all name+component values refer to valid components +-- in the given project package. +-- +-- * For names, check if the name is present in the snapshot, local +-- deps, or project packages. If it is not, then look up the most +-- recent version in the package index and convert to a +-- name+version. +-- +-- * For name+version, first ensure that the name is not used by a +-- project package. Next, if that name+version is present in the +-- snapshot or local deps _and_ its location is PLIndex, we have the +-- package. Otherwise, add to local deps with the appropriate +-- PLIndex. +-- +-- If in either of the last two bullets we added a package to local +-- deps, print a warning to the user recommending modifying the +-- extra-deps. +-- +-- Combine the various 'ResolveResults's together into 'Target' +-- values, by combining various components for a single package and +-- ensuring that no conflicting statements were made about targets. +-- +-- At this point, we now have a Map from package name to SimpleTarget, +-- and an updated Map of local dependencies. We still have the +-- aggregated flags, and the snapshot and project packages. +-- +-- Finally, we upgrade the snapshot by using +-- calculatePackagePromotion. module Stack.Build.Target ( -- * Types - ComponentName - , UnresolvedComponent (..) - , RawTarget (..) - , LocalPackageView (..) - , SimpleTarget (..) + Target (..) , NeedTargets (..) - -- * Parsers - , parseRawTarget + , PackageType (..) , parseTargets + -- * Convenience helpers + , gpdVersion + -- * Test suite exports + , parseRawTarget + , RawTarget (..) + , UnresolvedComponent (..) ) where import Control.Applicative -import Control.Arrow (second) -import Control.Monad.Catch (MonadCatch, throwM) -import Control.Monad.IO.Class +import Control.Monad (forM) +import Control.Monad.IO.Unlift +import Control.Monad.Logger import Data.Either (partitionEithers) import Data.Foldable -import Data.List.Extra (groupSort) -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 (mapMaybe) +import Data.Maybe (mapMaybe, isJust, catMaybes) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T +import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription) import Path import Path.Extra (rejectMissingDir) import Path.IO import Prelude hiding (concat, concatMap) -- Fix redundant import warnings +import Stack.Config (getLocalPackages) +import Stack.Fetch (withCabalLoader) +import Stack.Package +import Stack.PackageIndex +import Stack.PackageLocation +import Stack.Snapshot (calculatePackagePromotion) +import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import Stack.Types.Config import Stack.Types.Build -import Stack.Types.Package +import Stack.Types.BuildPlan +import Stack.Types.GhcPkgId +import Stack.Types.StackT --- | The name of a component, which applies to executables, test suites, and benchmarks -type ComponentName = Text +-- | Do we need any targets? For example, `stack build` will fail if +-- no targets are provided. +data NeedTargets = NeedTargets | AllowNoTargets + +--------------------------------------------------------------------------------- +-- Get the RawInput +--------------------------------------------------------------------------------- +-- | Raw target information passed on the command line. newtype RawInput = RawInput { unRawInput :: Text } +getRawInput :: BuildOptsCLI -> Map PackageName LocalPackageView -> ([Text], [RawInput]) +getRawInput boptscli locals = + let textTargets' = boptsCLITargets boptscli + textTargets = + -- Handle the no targets case, which means we pass in the names of all project packages + if null textTargets' + then map packageNameText (Map.keys locals) + else textTargets' + in (textTargets', map RawInput textTargets) + +--------------------------------------------------------------------------------- +-- Turn RawInput into RawTarget +--------------------------------------------------------------------------------- + +-- | The name of a component, which applies to executables, test +-- suites, and benchmarks +type ComponentName = Text + -- | Either a fully resolved component, or a component name that could be -- either an executable, test, or benchmark data UnresolvedComponent @@ -60,23 +143,50 @@ data UnresolvedComponent -- | Raw command line input, without checking against any databases or list of -- locals. Does not deal with directories -data RawTarget (a :: RawTargetType) where - RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a - RTComponent :: !ComponentName -> RawTarget a - RTPackage :: !PackageName -> RawTarget a - RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents +data RawTarget + = RTPackageComponent !PackageName !UnresolvedComponent + | RTComponent !ComponentName + | RTPackage !PackageName + -- Explicitly _not_ supporting revisions on the command line. If + -- you want that, you should be modifying your stack.yaml! (In + -- fact, you should probably do that anyway, we're just letting + -- people be lazy, since we're Haskeletors.) + | RTPackageIdentifier !PackageIdentifier + deriving (Show, Eq) -deriving instance Show (RawTarget a) -deriving instance Eq (RawTarget a) -deriving instance Ord (RawTarget a) +-- | Same as @parseRawTarget@, but also takes directories into account. +parseRawTargetDirs :: MonadIO m + => Path Abs Dir -- ^ current directory + -> Map PackageName LocalPackageView + -> RawInput -- ^ raw target information from the commandline + -> m (Either Text [(RawInput, RawTarget)]) +parseRawTargetDirs root locals ri = + case parseRawTarget t of + Just rt -> return $ Right [(ri, rt)] + Nothing -> do + mdir <- liftIO $ forgivingAbsence (resolveDir root (T.unpack t)) + >>= rejectMissingDir + case mdir of + Nothing -> return $ Left $ "Directory not found: " `T.append` t + Just dir -> + case mapMaybe (childOf dir) $ Map.toList locals of + [] -> return $ Left $ + "No local directories found as children of " `T.append` + t + names -> return $ Right $ map ((ri, ) . RTPackage) names + where + childOf dir (name, lpv) = + if dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv) + then Just name + else Nothing -data RawTargetType = HasIdents | NoIdents + RawInput t = ri -- | If this function returns @Nothing@, the input should be treated as a -- directory. -parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents) +parseRawTarget :: Text -> Maybe RawTarget parseRawTarget t = - (RTPackageIdentifier <$> parsePackageIdentifierFromString s) + (RTPackageIdentifier <$> parsePackageIdentifier t) <|> (RTPackage <$> parsePackageNameFromString s) <|> (RTComponent <$> T.stripPrefix ":" t) <|> parsePackageComponent @@ -104,94 +214,87 @@ parseRawTarget t = "bench" -> Just CBench _ -> Nothing --- | A view of a local package needed for resolving components -data LocalPackageView = LocalPackageView - { lpvVersion :: !Version - , lpvRoot :: !(Path Abs Dir) - , lpvCabalFP :: !(Path Abs File) - , lpvComponents :: !(Set NamedComponent) - , lpvExtraDep :: !TreatLikeExtraDep - } - --- | Same as @parseRawTarget@, but also takes directories into account. -parseRawTargetDirs :: (MonadIO m, MonadCatch m) - => Path Abs Dir -- ^ current directory - -> Map PackageName LocalPackageView - -> Text - -> m (Either Text [(RawInput, RawTarget 'HasIdents)]) -parseRawTargetDirs root locals t = - case parseRawTarget t of - Just rt -> return $ Right [(ri, rt)] - Nothing -> do - mdir <- forgivingAbsence (resolveDir root (T.unpack t)) - >>= rejectMissingDir - case mdir of - Nothing -> return $ Left $ "Directory not found: " `T.append` t - Just dir -> - case mapMaybe (childOf dir) $ Map.toList locals of - [] -> return $ Left $ - "No local directories found as children of " `T.append` - t - names -> return $ Right $ map ((ri, ) . RTPackage) names - where - ri = RawInput t - - childOf dir (name, lpv) = - if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv) - then Just name - else Nothing +--------------------------------------------------------------------------------- +-- Resolve the raw targets +--------------------------------------------------------------------------------- +-- | Simplified target information, after we've done a bunch of +-- resolving. data SimpleTarget - = STUnknown - | STNonLocal - | STLocalComps !(Set NamedComponent) - | STLocalAll + = STComponent !NamedComponent + -- ^ Targets a project package (non-dependency) with an explicit + -- component to be built. + | STDefaultComponents + -- ^ Targets a package with the default set of components (library + -- and all executables, plus test/bench for project packages if + -- the relevant flags are turned on). deriving (Show, Eq, Ord) -resolveIdents :: Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> (RawInput, RawTarget 'HasIdents) - -> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version) -resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty) -resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty) -resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty) -resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) = - fmap ((ri, RTPackage name), ) newExtras - where - newExtras = - case (Map.lookup name locals, mfound) of - -- Error if it matches a local package, pkg idents not - -- supported for local. - (Just _, _) -> Left $ T.concat - [ packageNameText name - , " target has a specific version number, but it is a local package." - , "\nTo avoid confusion, we will not install the specified version or build the local one." - , "\nTo build the local package, specify the target without an explicit version." - ] - -- If the found version matches, no need for an extra-dep. - (_, Just foundVersion) | foundVersion == version -> Right Map.empty - -- Otherwise, if there is no specified version or a - -- mismatch, add an extra-dep. - _ -> Right $ Map.singleton name version - mfound = asum (map (Map.lookup name) [extras, snap]) - -resolveRawTarget :: Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> (RawInput, RawTarget 'NoIdents) - -> Either Text (PackageName, (RawInput, SimpleTarget)) -resolveRawTarget snap extras locals (ri, rt) = +data ResolveResult = ResolveResult + { rrName :: !PackageName + , rrRaw :: !RawInput + , rrComponent :: !(Maybe NamedComponent) + -- ^ Was a concrete component specified? + , rrAddedDep :: !(Maybe Version) + -- ^ Only if we're adding this as a dependency + , rrPackageType :: !PackageType + } + +-- | Convert a 'RawTarget' into a 'ResolveResult' (see description on +-- the module). +resolveRawTarget + :: forall env m. (StackMiniM env m, HasConfig env) + => Map PackageName (LoadedPackageInfo GhcPkgId) -- ^ globals + -> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- ^ snapshot + -> Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath) -- ^ local deps + -> Map PackageName LocalPackageView -- ^ project packages + -> (RawInput, RawTarget) + -> m (Either Text ResolveResult) +resolveRawTarget globals snap deps locals (ri, rt) = go rt where - go (RTPackageComponent name ucomp) = + -- Helper function: check if a 'NamedComponent' matches the given 'ComponentName' + isCompNamed :: ComponentName -> NamedComponent -> Bool + isCompNamed _ CLib = False + isCompNamed t1 (CExe t2) = t1 == t2 + isCompNamed t1 (CTest t2) = t1 == t2 + isCompNamed t1 (CBench t2) = t1 == t2 + + go (RTComponent cname) = return $ + -- Associated list from component name to package that defines + -- it. We use an assoc list and not a Map so we can detect + -- duplicates. + let allPairs = concatMap + (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) + (Map.toList locals) + in case filter (isCompNamed cname . snd) allPairs of + [] -> 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 ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just comp + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } + matches -> Left $ T.concat + [ "Ambiugous component name " + , cname + , ", matches: " + , T.pack $ show matches + ] + go (RTPackageComponent name ucomp) = return $ case Map.lookup name locals of Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name Just lpv -> case ucomp of ResolvedComponent comp - | comp `Set.member` lpvComponents lpv -> - Right (name, (ri, STLocalComps $ Set.singleton comp)) + | comp `Set.member` lpvComponents lpv -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just comp + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } | otherwise -> Left $ T.pack $ concat [ "Component " , show comp @@ -206,7 +309,13 @@ resolveRawTarget snap extras locals (ri, rt) = , " does not exist in package " , T.pack $ packageNameString name ] - [x] -> Right (name, (ri, STLocalComps $ Set.singleton x)) + [x] -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Just x + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } matches -> Left $ T.concat [ "Ambiguous component name " , comp @@ -215,109 +324,277 @@ resolveRawTarget snap extras locals (ri, rt) = , ": " , T.pack $ show matches ] - go (RTComponent cname) = - let allPairs = concatMap - (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv) - (Map.toList locals) - in case filter (isCompNamed cname . snd) allPairs of - [] -> 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 - [ "Ambiugous component name " - , cname - , ", matches: " - , T.pack $ show matches - ] - go (RTPackage name) = - case Map.lookup name locals of - Just _lpv -> Right (name, (ri, STLocalAll)) - Nothing -> - case Map.lookup name extras of - Just _ -> Right (name, (ri, STNonLocal)) - Nothing -> - case Map.lookup name snap of - Just _ -> Right (name, (ri, STNonLocal)) - Nothing -> Right (name, (ri, STUnknown)) - -isCompNamed :: Text -> NamedComponent -> Bool -isCompNamed _ CLib = False -isCompNamed t1 (CExe t2) = t1 == t2 -isCompNamed t1 (CTest t2) = t1 == t2 -isCompNamed t1 (CBench t2) = t1 == t2 - -simplifyTargets :: [(PackageName, (RawInput, SimpleTarget))] - -> ([Text], Map PackageName SimpleTarget) -simplifyTargets = - foldMap go . collect + go (RTPackage name) + | Map.member name locals = return $ Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = ProjectPackage + } + | Map.member name deps || + Map.member name snap || + Map.member name globals = return $ Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = Dependency + } + | otherwise = do + mversion <- getLatestVersion name + return $ case mversion of + -- This is actually an error case. We _could_ return a + -- Left value here, but it turns out to be better to defer + -- this until the ConstructPlan phase, and let it complain + -- about the missing package so that we get more errors + -- together, plus the fancy colored output from that + -- module. + Nothing -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Nothing + , rrPackageType = Dependency + } + Just version -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just version + , rrPackageType = Dependency + } + where + getLatestVersion pn = do + vs <- getPackageVersions pn + return (fmap fst (Set.maxView vs)) + + go (RTPackageIdentifier ident@(PackageIdentifier name version)) + | Map.member name locals = return $ Left $ T.concat + [ packageNameText name + , " target has a specific version number, but it is a local package." + , "\nTo avoid confusion, we will not install the specified version or build the local one." + , "\nTo build the local package, specify the target without an explicit version." + ] + | otherwise = return $ + case Map.lookup name allLocs of + -- Installing it from the package index, so we're cool + -- with overriding it if necessary + Just (PLIndex (PackageIdentifierRevision (PackageIdentifier _name versionLoc) _mcfi)) -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = + if version == versionLoc + -- But no need to override anyway, this is already the + -- version we have + then Nothing + -- OK, we'll override it + else Just version + , rrPackageType = Dependency + } + -- The package was coming from something besides the + -- index, so refuse to do the override + Just (PLOther loc') -> Left $ T.concat + [ "Package with identifier was targeted on the command line: " + , packageIdentifierText ident + , ", but it was specified from a non-index location: " + , T.pack $ show loc' + , ".\nRecommendation: add the correctly desired version to extra-deps." + ] + -- Not present at all, so add it + Nothing -> Right ResolveResult + { rrName = name + , rrRaw = ri + , rrComponent = Nothing + , rrAddedDep = Just version + , rrPackageType = Dependency + } + + where + allLocs :: Map PackageName (PackageLocationIndex FilePath) + allLocs = Map.unions + [ Map.mapWithKey + (\name' lpi -> PLIndex $ PackageIdentifierRevision + (PackageIdentifier name' (lpiVersion lpi)) + Nothing) + globals + , Map.map lpiLocation snap + , Map.map snd deps + ] + +--------------------------------------------------------------------------------- +-- Combine the ResolveResults +--------------------------------------------------------------------------------- + +-- | How a package is intended to be built +data Target + = TargetAll !PackageType + -- ^ Build all of the default components. + | TargetComps !(Set NamedComponent) + -- ^ Only build specific components + +data PackageType = ProjectPackage | Dependency + deriving (Eq, Show) + +combineResolveResults + :: forall m. MonadLogger m + => [ResolveResult] + -> m ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) +combineResolveResults results = do + addedDeps <- fmap Map.unions $ forM results $ \result -> + case rrAddedDep result of + Nothing -> return Map.empty + Just version -> do + let ident = PackageIdentifier (rrName result) version + $logWarn $ T.concat + [ "- Implicitly adding " + , packageIdentifierText ident + , " to extra-deps based on command line target" + ] + return $ Map.singleton (rrName result) $ PLIndex $ PackageIdentifierRevision ident Nothing + + let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results + (errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) -> + -- Confirm that there is either exactly 1 with no component, or + -- that all rrs are components + case map rrComponent rrs of + [] -> assert False $ Left "Somehow got no rrComponent values, that can't happen" + [Nothing] -> Right $ Map.singleton name $ TargetAll $ rrPackageType $ head rrs + mcomps + | all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps + | otherwise -> Left $ T.concat + [ "The package " + , packageNameText name + , " was specified in multiple, incompatible ways: " + , T.unwords $ map (unRawInput . rrRaw) rrs + ] + + return (errs, Map.unions ms, addedDeps) + +--------------------------------------------------------------------------------- +-- OK, let's do it! +--------------------------------------------------------------------------------- + +parseTargets + :: (StackM env m, HasEnvConfig env) + => NeedTargets + -> BuildOptsCLI + -> m ( LoadedSnapshot -- upgraded snapshot, with some packages possibly moved to local + , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) -- all local deps + , Map PackageName Target + ) +parseTargets needTargets boptscli = do + $logDebug "Parsing the targets" + bconfig <- view buildConfigL + ls0 <- view loadedSnapshotL + workingDir <- getCurrentDir + lp <- getLocalPackages + let locals = lpProject lp + deps = lpDependencies lp + globals = lsGlobals ls0 + snap = lsPackages ls0 + let (textTargets', rawInput) = getRawInput boptscli locals + + (errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $ + parseRawTargetDirs workingDir (lpProject lp) + + (errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $ + resolveRawTarget globals snap deps locals + + (errs3, targets, addedDeps) <- combineResolveResults resolveResults + + case concat [errs1, errs2, errs3] of + [] -> return () + errs -> throwIO $ TargetParseException errs + + case (Map.null targets, needTargets) of + (False, _) -> return () + (True, AllowNoTargets) -> return () + (True, NeedTargets) + | null textTargets' && bcImplicitGlobal bconfig -> throwIO $ TargetParseException + ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] + | null textTargets' && Map.null locals -> throwIO $ TargetParseException + ["The project contains no local packages (packages not marked with 'extra-dep')"] + | otherwise -> throwIO $ TargetParseException + ["The specified targets matched no packages"] + + root <- view projectRootL + menv <- getMinimalEnvOverride + + let dropMaybeKey (Nothing, _) = Map.empty + dropMaybeKey (Just key, value) = Map.singleton key value + flags = Map.unionWith Map.union + (Map.unions (map dropMaybeKey (Map.toList (boptsCLIFlags boptscli)))) + (bcFlags bconfig) + hides = Map.empty -- not supported to add hidden packages + + -- We set this to empty here, which will prevent the call to + -- calculatePackagePromotion from promoting packages based on + -- changed GHC options. This is probably not ideal behavior, + -- but is consistent with pre-extensible-snapshots behavior of + -- Stack. We can consider modifying this instead. + -- + -- Nonetheless, GHC options will be calculated later based on + -- config file and command line parameters, so we're not + -- actually losing them. + options = Map.empty + + drops = Set.empty -- not supported to add drops + + (globals', snapshots, locals', upgraded) <- withCabalLoader $ \loadFromIndex -> do + addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do + bs <- loadSingleRawCabalFile loadFromIndex menv root loc + case rawParseGPD bs of + Left e -> throwIO $ InvalidCabalFileInLocal loc e bs + Right (_warnings, gpd) -> return (name, (gpd, loc, Nothing)) + + -- Calculate a list of all of the locals, based on the project + -- packages, local dependencies, and added deps found from the + -- command line + let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath, Maybe LocalPackageView) + allLocals = Map.unions + [ -- project packages + Map.map + (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv, Just lpv)) + (lpProject lp) + , -- added deps take precendence over local deps + addedDeps' + , -- added deps take precendence over local deps + Map.map + (\(gpd, loc) -> (gpd, loc, Nothing)) + (lpDependencies lp) + ] + + calculatePackagePromotion + loadFromIndex menv root ls0 (Map.elems allLocals) + flags hides options drops + + -- Warn about packages upgraded based on flags + forM_ upgraded $ \name -> $logWarn $ T.concat + [ "- Implicitly adding " + , packageNameText name + , " to extra-deps based on command line flag" + ] + + let ls = LoadedSnapshot + { lsCompilerVersion = lsCompilerVersion ls0 + , lsGlobals = globals' + , lsPackages = snapshots + } + + localDeps = Map.fromList $ flip mapMaybe (Map.toList locals') $ \(name, lpi) -> + -- We want to ignore any project packages, but grab the local + -- deps and upgraded snapshot deps + case lpiLocation lpi of + (_, Just (Just _localPackageView)) -> Nothing -- project package + (loc, _) -> Just (name, lpi { lpiLocation = loc }) -- upgraded or local dep + + return (ls, localDeps, targets) + +gpdVersion :: GenericPackageDescription -> Version +gpdVersion gpd = + version where - go :: (PackageName, NonEmpty (RawInput, SimpleTarget)) - -> ([Text], Map PackageName SimpleTarget) - go (name, (_, st) :| []) = ([], Map.singleton name st) - go (name, pairs) = - case partitionEithers $ map (getLocalComp . snd) (NonEmpty.toList pairs) of - ([], comps) -> ([], Map.singleton name $ STLocalComps $ Set.unions comps) - _ -> - let err = T.pack $ concat - [ "Overlapping targets provided for package " - , packageNameString name - , ": " - , show $ map (unRawInput . fst) (NonEmpty.toList pairs) - ] - in ([err], Map.empty) - - collect :: Ord a => [(a, b)] -> [(a, NonEmpty b)] - collect = map (second NonEmpty.fromList) . groupSort - - getLocalComp (STLocalComps comps) = Right comps - getLocalComp _ = Left () - --- | Need targets, e.g. `stack build` or allow none? -data NeedTargets - = NeedTargets - | AllowNoTargets - -parseTargets :: (MonadCatch m, MonadIO m) - => NeedTargets -- ^ need at least one target - -> Bool -- ^ using implicit global project? - -> Map PackageName Version -- ^ snapshot - -> Map PackageName Version -- ^ extra deps - -> Map PackageName LocalPackageView - -> Path Abs Dir -- ^ current directory - -> [Text] -- ^ command line targets - -> m (Map PackageName Version, Map PackageName SimpleTarget) -parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do - let nonExtraDeps = Map.keys $ Map.filter (not . lpvExtraDep) locals - textTargets = - if null textTargets' - then map (T.pack . packageNameString) nonExtraDeps - else textTargets' - erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets - - let (errs1, rawTargets) = partitionEithers erawTargets - -- When specific package identifiers are provided, treat these - -- as extra-deps. - (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $ - map (resolveIdents snap extras locals) $ concat rawTargets - -- Find targets that specify components in the local packages, - -- otherwise find package targets in snap and extra-deps. - (errs3, targetTypes) = partitionEithers $ - map (resolveRawTarget snap extras locals) rawTargets' - (errs4, targets) = simplifyTargets targetTypes - errs = concat [errs1, errs2, errs3, errs4] - - if null errs - then if Map.null targets - then case needTargets of - AllowNoTargets -> - return (Map.empty, Map.empty) - NeedTargets - | null textTargets' && implicitGlobal -> throwM $ TargetParseException - ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] - | null textTargets' && null nonExtraDeps -> throwM $ TargetParseException - ["The project contains no local packages (packages not marked with 'extra-dep')"] - | otherwise -> throwM $ TargetParseException - ["The specified targets matched no packages"] - else return (Map.unions newExtras, targets) - else throwM $ TargetParseException errs + PackageIdentifier _ version = fromCabalPackageIdentifier $ package $ packageDescription gpd diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 2e38ecf7cd..94e52e9f99 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -20,38 +22,15 @@ module Stack.BuildPlan , gpdPackageDeps , gpdPackages , gpdPackageName - , MiniBuildPlan(..) - , MiniPackageInfo(..) - , loadResolver - , loadMiniBuildPlan , removeSrcPkgDefaultFlags - , resolveBuildPlan , selectBestSnapshot , getToolMap - , shadowMiniBuildPlan , showItems - , showPackageFlags - , parseCustomMiniBuildPlan - , loadBuildPlan ) where import Control.Applicative -import Control.Exception (assert) -import Control.Monad (liftM, forM, unless) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Reader (MonadReader) -import Control.Monad.State.Strict (State, execState, get, modify, - put) -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 -import Data.Either (partitionEithers) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.List (intercalate) @@ -59,41 +38,33 @@ 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 (fromMaybe, mapMaybe, isNothing) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Traversable as Tr import Data.Typeable (Typeable) -import Data.Yaml (decodeEither', decodeFileEither) import qualified Distribution.Package as C import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, flagName, genPackageFlags, - executables, exeName, library, libBuildInfo, buildable) + condExecutables) import qualified Distribution.PackageDescription as C import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C -import Network.HTTP.Download import Path -import Path.IO import Prelude -- Fix AMP warning import Stack.Constants -import Stack.Fetch import Stack.Package -import Stack.PackageIndex +import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.FlagName import Stack.Types.PackageIdentifier -import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version import Stack.Types.Config -import Stack.Types.Urls import Stack.Types.Compiler import Stack.Types.Resolver import Stack.Types.StackT @@ -104,7 +75,6 @@ data BuildPlanException (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown (Map PackageName (Set PackageIdentifier)) -- shadowed | SnapshotNotFound SnapName - | FilepathInDownloadedSnapshot T.Text | NeitherCompilerOrResolverSpecified T.Text deriving (Typeable) instance Exception BuildPlanException @@ -182,223 +152,17 @@ instance Show BuildPlanException where $ Set.toList $ Set.unions $ Map.elems shadowed - show (FilepathInDownloadedSnapshot url) = unlines - [ "Downloaded snapshot specified a 'resolver: { location: filepath }' " - , "field, but filepaths are not allowed in downloaded snapshots.\n" - , "Filepath specified: " ++ T.unpack url - ] show (NeitherCompilerOrResolverSpecified url) = "Failed to load custom snapshot at " ++ T.unpack url ++ ", because no 'compiler' or 'resolver' is specified." --- | Determine the necessary packages to install to have the given set of --- packages available. --- --- This function will not provide test suite and benchmark dependencies. --- --- This may fail if a target package is not present in the @BuildPlan@. -resolveBuildPlan - :: (StackMiniM env m, HasBuildConfig env) - => MiniBuildPlan - -> (PackageName -> Bool) -- ^ is it shadowed by a local package? - -> Map PackageName (Set PackageName) -- ^ required packages, and users of it - -> m ( Map PackageName (Version, Map FlagName Bool) - , Map PackageName (Set PackageName) - ) -resolveBuildPlan mbp isShadowed packages - | Map.null (rsUnknown rs) && Map.null (rsShadowed rs) = return (rsToInstall rs, rsUsedBy rs) - | otherwise = do - bconfig <- view buildConfigL - (caches, _gitShaCaches) <- getPackageCaches - let maxVer = - Map.fromListWith max $ - map toTuple $ - Map.keys caches - unknown = flip Map.mapWithKey (rsUnknown rs) $ \ident x -> - (Map.lookup ident maxVer, x) - throwM $ UnknownPackages - (bcStackYaml bconfig) - unknown - (rsShadowed rs) - where - rs = getDeps mbp isShadowed packages - -data ResolveState = ResolveState - { rsVisited :: Map PackageName (Set PackageName) -- ^ set of shadowed dependencies - , rsUnknown :: Map PackageName (Set PackageName) - , rsShadowed :: Map PackageName (Set PackageIdentifier) - , rsToInstall :: Map PackageName (Version, Map FlagName Bool) - , rsUsedBy :: Map PackageName (Set PackageName) - } - -toMiniBuildPlan - :: (StackMiniM env m, HasConfig env) - => CompilerVersion -- ^ Compiler version - -> Map PackageName Version -- ^ cores - -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages - -> m MiniBuildPlan -toMiniBuildPlan compilerVersion corePackages packages = do - -- Determine the dependencies of all of the packages in the build plan. We - -- handle core packages specially, because some of them will not be in the - -- package index. For those, we allow missing packages to exist, and then - -- remove those from the list of dependencies, since there's no way we'll - -- ever reinstall them anyway. - (cores, missingCores) <- addDeps True compilerVersion - $ fmap (, Map.empty, [], Nothing) corePackages - - (extras, missing) <- addDeps False compilerVersion packages - - assert (Set.null missing) $ return MiniBuildPlan - { mbpCompilerVersion = compilerVersion - , mbpPackages = Map.unions - [ fmap (removeMissingDeps (Map.keysSet cores)) cores - , extras - , Map.fromList $ map goCore $ Set.toList missingCores - ] - } - where - goCore (PackageIdentifier name version) = (name, MiniPackageInfo - { mpiVersion = version - , mpiFlags = Map.empty - , mpiGhcOptions = [] - , mpiPackageDeps = Set.empty - , mpiToolDeps = Set.empty - , mpiExes = Set.empty - , mpiHasLibrary = True - , mpiGitSHA1 = Nothing - }) - - removeMissingDeps cores mpi = mpi - { mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi) - } - --- | Add in the resolved dependencies from the package index -addDeps - :: (StackMiniM env m, HasConfig env) - => Bool -- ^ allow missing - -> CompilerVersion -- ^ Compiler version - -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) - -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) -addDeps allowMissing compilerVersion toCalc = do - platform <- view platformL - (resolvedMap, missingIdents) <- - if allowMissing - then do - (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing Nothing shaMap Set.empty - assert (Set.null missingNames) - $ return (m, missingIdents) - else do - m <- resolvePackages Nothing shaMap Set.empty - return (m, Set.empty) - let byIndex = Map.fromListWith (++) $ flip map resolvedMap - $ \rp -> - let (cache, ghcOptions, sha) = - case Map.lookup (packageIdentifierName (rpIdent rp)) toCalc of - Nothing -> (Map.empty, [], Nothing) - Just (_, x, y, z) -> (x, y, z) - 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 - let packageConfig = PackageConfig - { packageConfigEnableTests = False - , packageConfigEnableBenchmarks = False - , packageConfigFlags = flags - , packageConfigGhcOptions = ghcOptions - , packageConfigCompilerVersion = compilerVersion - , packageConfigPlatform = platform - } - name = packageIdentifierName ident - pd = resolvePackageDescription packageConfig gpd - exes = Set.fromList $ map (ExeName . T.pack . exeName) $ executables pd - notMe = Set.filter (/= name) . Map.keysSet - return (name, MiniPackageInfo - { mpiVersion = packageIdentifierVersion ident - , mpiFlags = flags - , mpiGhcOptions = ghcOptions - , mpiPackageDeps = notMe $ packageDependencies pd - , mpiToolDeps = Map.keysSet $ packageToolDependencies pd - , mpiExes = exes - , mpiHasLibrary = maybe - False - (buildable . libBuildInfo) - (library pd) - , mpiGitSHA1 = mgitSha - }) - return (Map.fromList $ concat res, missingIdents) - where - shaMap = Map.fromList - $ map (\(n, (v, _f, _ghcOptions, gitsha)) -> (PackageIdentifier n v, gitsha)) - $ Map.toList toCalc - --- | Resolve all packages necessary to install for the needed packages. -getDeps :: MiniBuildPlan - -> (PackageName -> Bool) -- ^ is it shadowed by a local package? - -> Map PackageName (Set PackageName) - -> ResolveState -getDeps mbp isShadowed packages = - execState (mapM_ (uncurry goName) $ Map.toList packages) ResolveState - { rsVisited = Map.empty - , rsUnknown = Map.empty - , rsShadowed = Map.empty - , rsToInstall = Map.empty - , rsUsedBy = Map.empty - } - where - toolMap = getToolMap mbp - - -- | Returns a set of shadowed packages we depend on. - goName :: PackageName -> Set PackageName -> State ResolveState (Set PackageName) - goName name users = do - -- Even though we could check rsVisited first and short-circuit things - -- earlier, lookup in mbpPackages first so that we can produce more - -- usable error information on missing dependencies - rs <- get - put rs - { rsUsedBy = Map.insertWith Set.union name users $ rsUsedBy rs - } - case Map.lookup name $ mbpPackages mbp of - Nothing -> do - modify $ \rs' -> rs' - { rsUnknown = Map.insertWith Set.union name users $ rsUnknown rs' - } - return Set.empty - Just mpi -> case Map.lookup name (rsVisited rs) of - Just shadowed -> return shadowed - Nothing -> do - put rs { rsVisited = Map.insert name Set.empty $ rsVisited rs } - let depsForTools = Set.unions $ mapMaybe (flip Map.lookup toolMap) (Set.toList $ mpiToolDeps mpi) - let deps = Set.filter (/= name) (mpiPackageDeps mpi <> depsForTools) - shadowed <- fmap F.fold $ Tr.forM (Set.toList deps) $ \dep -> - if isShadowed dep - then do - modify $ \rs' -> rs' - { rsShadowed = Map.insertWith - Set.union - dep - (Set.singleton $ PackageIdentifier name (mpiVersion mpi)) - (rsShadowed rs') - } - return $ Set.singleton dep - else do - shadowed <- goName dep (Set.singleton name) - let m = Map.fromSet (\_ -> Set.singleton $ PackageIdentifier name (mpiVersion mpi)) shadowed - modify $ \rs' -> rs' - { rsShadowed = Map.unionWith Set.union m $ rsShadowed rs' - } - return shadowed - modify $ \rs' -> rs' - { rsToInstall = Map.insert name (mpiVersion mpi, mpiFlags mpi) $ rsToInstall rs' - , rsVisited = Map.insert name shadowed $ rsVisited rs' - } - return shadowed - --- | Map from tool name to package providing it -getToolMap :: MiniBuildPlan -> Map Text (Set PackageName) -getToolMap mbp = - Map.unionsWith Set.union +-- | Map from tool name to package providing it. This accounts for +-- both snapshot and local packages (deps and project packages). +getToolMap :: LoadedSnapshot + -> LocalPackages + -> Map Text (Set PackageName) +getToolMap ls locals = {- We no longer do this, following discussion at: @@ -409,111 +173,30 @@ getToolMap mbp = $ Map.fromList (map (packageNameByteString &&& Set.singleton) (Map.keys ps)) -} - -- And then get all of the explicit executable names - $ concatMap goPair (Map.toList ps) + Map.unionsWith Set.union $ concat + [ concatMap goSnap $ Map.toList $ lsPackages ls + , concatMap goLocalProj $ Map.toList $ lpProject locals + , concatMap goLocalDep $ Map.toList $ lpDependencies locals + ] where - ps = mbpPackages mbp - - goPair (pname, mpi) = + goSnap (pname, lpi) = map (flip Map.singleton (Set.singleton pname) . unExeName) $ Set.toList - $ mpiExes mpi + $ lpiProvidedExes lpi -loadResolver - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => Maybe (Path Abs File) - -> Resolver - -> m (MiniBuildPlan, LoadedResolver) -loadResolver mconfigPath resolver = - case resolver of - ResolverSnapshot snap -> - liftM (, ResolverSnapshot snap) $ loadMiniBuildPlan snap - -- TODO(mgsloan): Not sure what this FIXME means - -- FIXME instead of passing the stackYaml dir we should maintain - -- the file URL in the custom resolver always relative to stackYaml. - ResolverCustom name url -> do - (mbp, hash) <- parseCustomMiniBuildPlan mconfigPath url - return (mbp, ResolverCustomLoaded name url hash) - ResolverCompiler compiler -> return - ( MiniBuildPlan - { mbpCompilerVersion = compiler - , mbpPackages = mempty - } - , ResolverCompiler compiler - ) + goLocalProj (pname, lpv) = + map (flip Map.singleton (Set.singleton pname)) + [t | CExe t <- Set.toList (lpvComponents lpv)] --- | Load up a 'MiniBuildPlan', preferably from cache -loadMiniBuildPlan - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => SnapName -> m MiniBuildPlan -loadMiniBuildPlan name = do - path <- configMiniBuildPlanCache name - $(versionedDecodeOrLoad miniBuildPlanVC) path $ liftM buildPlanFixes $ do - bp <- loadBuildPlan name - toMiniBuildPlan - (siCompilerVersion $ bpSystemInfo bp) - (siCorePackages $ bpSystemInfo bp) - (goPP <$> bpPackages bp) - where - goPP pp = - ( ppVersion pp - , pcFlagOverrides $ ppConstraints pp - -- TODO: store ghc options in BuildPlan? - , [] - , ppCabalFileInfo pp - >>= fmap (GitSHA1 . encodeUtf8) - . Map.lookup "GitSHA1" - . cfiHashes - ) + goLocalDep (pname, (gpd, _loc)) = + map (flip Map.singleton (Set.singleton pname)) + $ gpdExes gpd --- | Some hard-coded fixes for build plans, hopefully to be irrelevant over --- time. -buildPlanFixes :: MiniBuildPlan -> MiniBuildPlan -buildPlanFixes mbp = mbp - { mbpPackages = Map.fromList $ map go $ Map.toList $ mbpPackages mbp - } - where - go (name, mpi) = - (name, mpi - { mpiFlags = goF (packageNameString name) (mpiFlags mpi) - }) - - goF "persistent-sqlite" = Map.insert $(mkFlagName "systemlib") False - goF "yaml" = Map.insert $(mkFlagName "system-libyaml") False - goF _ = id - --- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy --- if available, otherwise downloading from Github. -loadBuildPlan :: (StackMiniM env m, HasConfig env) => SnapName -> m BuildPlan -loadBuildPlan name = do - stackage <- view stackRootL - file' <- parseRelFile $ T.unpack file - let fp = buildPlanDir stackage file' - $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) - eres <- liftIO $ decodeFileEither $ toFilePath fp - case eres of - Right bp -> return bp - Left e -> do - $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e) - ensureDir (parent fp) - url <- buildBuildPlanUrl name file - req <- parseRequest $ T.unpack url - $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." - $logDebug $ "Downloading build plan from: " <> url - _ <- redownload req fp - $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." - liftIO (decodeFileEither $ toFilePath fp) >>= either throwM return - - where - file = renderSnapName name <> ".yaml" - -buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text -buildBuildPlanUrl name file = do - urls <- view $ configL.to configUrls - return $ - case name of - LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file - Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file + -- TODO consider doing buildable checking. Not a big deal though: + -- worse case scenario is we build an extra package that wasn't + -- strictly needed. + gpdExes :: GenericPackageDescription -> [Text] + gpdExes = map (T.pack . fst) . condExecutables gpdPackages :: [GenericPackageDescription] -> Map PackageName Version gpdPackages gpds = Map.fromList $ @@ -530,7 +213,7 @@ gpdPackageName = fromCabalPackageName gpdPackageDeps :: GenericPackageDescription - -> CompilerVersion + -> CompilerVersion 'CVActual -> Platform -> Map FlagName Bool -> Map PackageName VersionRange @@ -577,7 +260,7 @@ removeSrcPkgDefaultFlags gpds flags = -- Returns the plan which produces least number of dep errors selectPackageBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> GenericPackageDescription -> (Map PackageName (Map FlagName Bool), DepErrors) @@ -616,7 +299,7 @@ selectPackageBuildPlan platform compiler pool gpd = -- constraints can be satisfied against a given build plan or pool of packages. checkPackageBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> Map FlagName Bool -> GenericPackageDescription @@ -670,7 +353,7 @@ combineDepError (DepError a x) (DepError b y) = -- will be chosen automatically. checkBundleBuildPlan :: Platform - -> CompilerVersion + -> CompilerVersion 'CVActual -> Map PackageName Version -> Maybe (Map PackageName (Map FlagName Bool)) -> [GenericPackageDescription] @@ -694,7 +377,7 @@ data BuildPlanCheck = BuildPlanCheckOk (Map PackageName (Map FlagName Bool)) | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors - CompilerVersion + (CompilerVersion 'CVActual) -- | Compare 'BuildPlanCheck', where GT means a better plan. compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering @@ -720,17 +403,21 @@ instance Show BuildPlanCheck where -- the packages. checkSnapBuildPlan :: (StackM env m, HasConfig env, HasGHCVariant env) - => [GenericPackageDescription] + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> [GenericPackageDescription] -> Maybe (Map PackageName (Map FlagName Bool)) - -> SnapName + -> SnapshotDef -> m BuildPlanCheck -checkSnapBuildPlan gpds flags snap = do +checkSnapBuildPlan root gpds flags snapshotDef = do platform <- view platformL - mbp <- loadMiniBuildPlan snap + menv <- getMinimalEnvOverride + rs <- loadSnapshot menv Nothing root snapshotDef let - compiler = mbpCompilerVersion mbp - snapPkgs = mpiVersion <$> mbpPackages mbp + compiler = lsCompilerVersion rs + snapPkgs = Map.union + (lpiVersion <$> lsGlobals rs) + (lpiVersion <$> lsPackages rs) (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds cerrs = compilerErrors compiler errs @@ -753,10 +440,11 @@ checkSnapBuildPlan gpds flags snap = do -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot :: (StackM env m, HasConfig env, HasGHCVariant env) - => [GenericPackageDescription] - -> NonEmpty SnapName - -> m (SnapName, BuildPlanCheck) -selectBestSnapshot gpds snaps = do + => Path Abs Dir -- ^ project root, used for checking out necessary files + -> [GenericPackageDescription] + -> NonEmpty SnapshotDef + -> m (SnapshotDef, BuildPlanCheck) +selectBestSnapshot root gpds snaps = do $logInfo $ "Selecting the best among " <> T.pack (show (NonEmpty.length snaps)) <> " snapshots...\n" @@ -769,7 +457,7 @@ selectBestSnapshot gpds snaps = do _ -> fmap (betterSnap old) mnew getResult snap = do - result <- checkSnapBuildPlan gpds Nothing snap + result <- checkSnapBuildPlan root gpds Nothing snap reportResult result snap return (snap, result) @@ -778,15 +466,15 @@ selectBestSnapshot gpds snaps = do | otherwise = (s2, r2) reportResult BuildPlanCheckOk {} snap = do - $logInfo $ "* Matches " <> renderSnapName snap + $logInfo $ "* Matches " <> sdResolverName snap $logInfo "" reportResult r@BuildPlanCheckPartial {} snap = do - $logWarn $ "* Partially matches " <> renderSnapName snap + $logWarn $ "* Partially matches " <> sdResolverName snap $logWarn $ indent $ T.pack $ show r reportResult r@BuildPlanCheckFail {} snap = do - $logWarn $ "* Rejected " <> renderSnapName snap + $logWarn $ "* Rejected " <> sdResolverName snap $logWarn $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) @@ -821,7 +509,7 @@ showMapPackages mp = showItems $ Map.keys mp showCompilerErrors :: Map PackageName (Map FlagName Bool) -> DepErrors - -> CompilerVersion + -> CompilerVersion 'CVActual -> Text showCompilerErrors flags errs compiler = T.concat @@ -867,236 +555,3 @@ showDepErrors flags errs = flagVals = T.concat (map showFlags userPkgs) userPkgs = Map.keys $ Map.unions (Map.elems (fmap deNeededBy errs)) showFlags pkg = maybe "" (showPackageFlags pkg) (Map.lookup pkg flags) - --- | Given a set of packages to shadow, this removes them, and any --- packages that transitively depend on them, from the 'MiniBuildPlan'. --- The 'Map' result yields all of the packages that were downstream of --- the shadowed packages. It does not include the shadowed packages. -shadowMiniBuildPlan :: MiniBuildPlan - -> Set PackageName - -> (MiniBuildPlan, Map PackageName MiniPackageInfo) -shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed = - (MiniBuildPlan cv (Map.fromList met), Map.fromList unmet) - where - pkgs1 = Map.difference pkgs0 $ Map.fromSet (const ()) shadowed - - depsMet = flip execState Map.empty $ mapM_ (check Set.empty) (Map.keys pkgs1) - - check visited name - | name `Set.member` visited = - error $ "shadowMiniBuildPlan: cycle detected, your MiniBuildPlan is broken: " ++ show (visited, name) - | otherwise = do - m <- get - case Map.lookup name m of - Just x -> return x - Nothing -> - case Map.lookup name pkgs1 of - Nothing - | name `Set.member` shadowed -> return False - - -- In this case, we have to assume that we're - -- constructing a build plan on a different OS or - -- architecture, and therefore different packages - -- are being chosen. The common example of this is - -- the Win32 package. - | otherwise -> return True - Just mpi -> do - let visited' = Set.insert name visited - ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi) - let res = and ress - modify $ \m' -> Map.insert name res m' - return res - - (met, unmet) = partitionEithers $ map toEither $ Map.toList pkgs1 - - toEither pair@(name, _) = - wrapper pair - where - wrapper = - case Map.lookup name depsMet of - Just True -> Left - Just False -> Right - Nothing -> assert False Right - --- This works differently for snapshots fetched from URL and those --- fetched from file: --- --- 1) If downloading the snapshot from a URL, assume the fetched data is --- immutable. Hash the URL in order to determine the location of the --- cached download. The file contents of the snapshot determines the --- hash for looking up cached MBP. --- --- 2) If loading the snapshot from a file, load all of the involved --- snapshot files. The hash used to determine the cached MBP is the hash --- of the concatenation of the parent's hash with the snapshot contents. --- --- Why this difference? We want to make it easy to simply edit snapshots --- in the filesystem, but we want caching for remote snapshots. In order --- to avoid reparsing / reloading all the yaml for remote snapshots, we --- need a different hash system. - --- TODO: This could probably be more efficient if it first merged the --- custom snapshots, and then applied them to the MBP. It is nice to --- apply directly, because then we have the guarantee that it's --- semantically identical to snapshot extension. If this optimization is --- implemented, note that the direct Monoid for CustomSnapshot is not --- correct. Crucially, if a package is present in the snapshot, its --- flags and ghc-options are not based on settings from prior snapshots. --- TODO: This semantics should be discussed / documented more. - --- TODO: allow a hash check in the resolver. This adds safety / --- correctness, allowing you to ensure that you are indeed getting the --- right custom snapshot. - --- TODO: Allow custom plan to specify a name. - -parseCustomMiniBuildPlan - :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath - -> T.Text - -> m (MiniBuildPlan, SnapshotHash) -parseCustomMiniBuildPlan mconfigPath0 url0 = do - $logDebug $ "Loading " <> url0 <> " build plan" - case parseUrlThrow $ T.unpack url0 of - Just req -> downloadCustom url0 req - Nothing -> - case mconfigPath0 of - Nothing -> throwM $ FilepathInDownloadedSnapshot url0 - Just configPath -> do - (getMbp, hash) <- readCustom configPath url0 - mbp <- getMbp - -- NOTE: We make the choice of only writing a cache - -- file for the full MBP, not the intermediate ones. - -- This isn't necessarily the best choice if we want - -- to share work extended snapshots. I think only - -- writing this one is more efficient for common - -- cases. - binaryPath <- getBinaryPath hash - alreadyCached <- doesFileExist binaryPath - unless alreadyCached $ $(versionedEncodeFile miniBuildPlanVC) binaryPath mbp - return (mbp, hash) - where - downloadCustom url req = do - let urlHash = S8.unpack $ trimmedSnapshotHash $ doHash $ encodeUtf8 url - hashFP <- parseRelFile $ urlHash ++ ".yaml" - customPlanDir <- getCustomPlanDir - let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP - _ <- download req cacheFP - yamlBS <- liftIO $ S.readFile $ toFilePath cacheFP - let yamlHash = doHash yamlBS - binaryPath <- getBinaryPath yamlHash - liftM (, yamlHash) $ $(versionedDecodeOrLoad miniBuildPlanVC) binaryPath $ do - (cs, mresolver) <- decodeYaml yamlBS - parentMbp <- case (csCompilerVersion cs, mresolver) of - (Nothing, Nothing) -> throwM (NeitherCompilerOrResolverSpecified url) - (Just cv, Nothing) -> return (compilerBuildPlan cv) - -- NOTE: ignoring the parent's hash, even though - -- there could be one. URL snapshot's hash are - -- determined just from their contents. - (_, Just resolver) -> liftM fst (loadResolver Nothing resolver) - applyCustomSnapshot cs parentMbp - readCustom configPath path = do - yamlFP <- resolveFile (parent configPath) (T.unpack $ fromMaybe path $ - T.stripPrefix "file://" path <|> T.stripPrefix "file:" path) - yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP - (cs, mresolver) <- decodeYaml yamlBS - (getMbp, hash) <- case mresolver of - Just (ResolverCustom _ url ) -> - case parseUrlThrow $ T.unpack url of - Just req -> do - let getMbp = do - -- Ignore custom hash, under the - -- assumption that the URL is sufficient - -- for identity. - (mbp, _) <- downloadCustom url req - return mbp - return (getMbp, doHash yamlBS) - Nothing -> do - (getMbp0, SnapshotHash hash0) <- readCustom yamlFP url - let hash = doHash (hash0 <> yamlBS) - getMbp = do - binaryPath <- getBinaryPath hash - -- Idea here is to not waste time - -- writing out intermediate cache files, - -- but check for them. - exists <- doesFileExist binaryPath - if exists - then do - eres <- $(versionedDecodeFile miniBuildPlanVC) binaryPath - case eres of - Just mbp -> return mbp - -- Invalid format cache file, remove. - Nothing -> do - removeFile binaryPath - getMbp0 - else getMbp0 - return (getMbp, hash) - Just resolver -> do - -- NOTE: in the cases where we don't have a hash, the - -- normal resolver name is enough. Since this name is - -- part of the yaml file, it ends up in our hash. - let hash = doHash yamlBS - getMbp = do - (mbp, resolver') <- loadResolver (Just configPath) resolver - let mhash = customResolverHash resolver' - assert (isNothing mhash) (return mbp) - return (getMbp, hash) - Nothing -> do - case csCompilerVersion cs of - Nothing -> throwM (NeitherCompilerOrResolverSpecified path) - Just cv -> do - let hash = doHash yamlBS - getMbp = return (compilerBuildPlan cv) - return (getMbp, hash) - return (applyCustomSnapshot cs =<< getMbp, hash) - getBinaryPath hash = do - binaryFilename <- parseRelFile $ S8.unpack (trimmedSnapshotHash hash) ++ ".bin" - customPlanDir <- getCustomPlanDir - return $ customPlanDir $(mkRelDir "bin") binaryFilename - decodeYaml yamlBS = do - WithJSONWarnings res warnings <- - either (throwM . ParseCustomSnapshotException url0) return $ - decodeEither' yamlBS - logJSONWarnings (T.unpack url0) warnings - return res - compilerBuildPlan cv = MiniBuildPlan - { mbpCompilerVersion = cv - , mbpPackages = mempty - } - getCustomPlanDir = do - root <- view stackRootL - return $ root $(mkRelDir "custom-plan") - doHash = SnapshotHash . B64URL.encode . Mem.convert . hashWith SHA256 - -applyCustomSnapshot - :: (StackMiniM env m, HasConfig env) - => CustomSnapshot - -> MiniBuildPlan - -> m MiniBuildPlan -applyCustomSnapshot cs mbp0 = do - let CustomSnapshot mcompilerVersion - packages - dropPackages - (PackageFlags flags) - ghcOptions - = cs - addFlagsAndOpts :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool, [Text], Maybe GitSHA1)) - addFlagsAndOpts (PackageIdentifier name ver) = - ( name - , ( ver - , Map.findWithDefault Map.empty name flags - -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build - , ghcOptionsFor name ghcOptions - -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots - , Nothing - ) - ) - packageMap = Map.fromList $ map addFlagsAndOpts $ Set.toList packages - cv = fromMaybe (mbpCompilerVersion mbp0) mcompilerVersion - packages0 = - mbpPackages mbp0 `Map.difference` Map.fromSet (const ()) dropPackages - mbp1 <- toMiniBuildPlan cv mempty packageMap - return MiniBuildPlan - { mbpCompilerVersion = cv - , mbpPackages = Map.union (mbpPackages mbp1) packages0 - } diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs index 62bbe73067..bf66dd4d79 100644 --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -9,8 +9,7 @@ module Stack.Clean ,StackCleanException(..) ) where -import Control.Exception (Exception) -import Control.Monad.Catch (throwM) +import Control.Monad.IO.Unlift import Data.Foldable (forM_) import Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map @@ -18,8 +17,6 @@ import Data.Maybe (mapMaybe) import Data.Typeable (Typeable) import Path (Path, Abs, Dir) import Path.IO (ignoringAbsence, removeDirRecur) -import Stack.Build.Source (getLocalPackageViews) -import Stack.Build.Target (LocalPackageView(..)) import Stack.Config (getLocalPackages) import Stack.Constants (distDirFromDir, workDirFromDir) import Stack.Types.PackageName @@ -35,7 +32,7 @@ clean -> m () clean cleanOpts = do dirs <- dirsToDelete cleanOpts - forM_ dirs (ignoringAbsence . removeDirRecur) + liftIO $ forM_ dirs (ignoringAbsence . removeDirRecur) dirsToDelete :: (StackM env m, HasEnvConfig env) @@ -43,19 +40,19 @@ dirsToDelete -> m [Path Abs Dir] dirsToDelete cleanOpts = do packages <- getLocalPackages - let localPkgDirs = Map.keys packages case cleanOpts of - CleanShallow [] -> do - mapM distDirFromDir localPkgDirs + CleanShallow [] -> + -- Filter out packages listed as extra-deps + mapM (distDirFromDir . lpvRoot) $ Map.elems $ lpProject packages CleanShallow targets -> do - localPkgViews <- getLocalPackageViews - let localPkgNames = Map.keys localPkgViews - getPkgDir pkgName = fmap (lpvRoot . fst) (Map.lookup pkgName localPkgViews) + let localPkgViews = lpProject packages + localPkgNames = Map.keys localPkgViews + getPkgDir pkgName = fmap lpvRoot (Map.lookup pkgName localPkgViews) case targets \\ localPkgNames of [] -> mapM distDirFromDir (mapMaybe getPkgDir targets) xs -> throwM (NonLocalPackages xs) CleanFull -> do - pkgWorkDirs <- mapM workDirFromDir localPkgDirs + pkgWorkDirs <- mapM (workDirFromDir . lpvRoot) $ Map.elems $ lpProject packages projectWorkDir <- getProjectWorkDir return (projectWorkDir : pkgWorkDirs) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index a7061771e3..0cdddd9066 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} @@ -33,7 +34,6 @@ module Stack.Config ,loadConfigYaml ,packagesParser ,getLocalPackages - ,resolvePackageEntry ,getImplicitGlobalProjectDir ,getStackYaml ,getSnapshots @@ -46,40 +46,32 @@ module Stack.Config ,LocalConfigStatus(..) ) where -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Archive.Zip as Zip -import qualified Codec.Compression.GZip as GZip import Control.Applicative -import Control.Arrow ((***)) -import Control.Exception (assert) -import Control.Monad (liftM, unless, when, filterM) -import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM, catch) +import Control.Arrow ((***), second) +import Control.Monad (liftM, unless, when, filterM, forM) import Control.Monad.Extra (firstJustM) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (Loc) 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 import Data.Foldable (forM_) import Data.IORef import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Maybe import Data.Monoid.Extra +import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (encodeUtf8) import qualified Data.Yaml as Yaml +import qualified Distribution.PackageDescription as C import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch)) 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) import Options.Applicative (Parser, strOption, long, help) import Path @@ -87,19 +79,24 @@ import Path.Extra (toFilePathNoTrailingSep) import Path.Find (findInParents) import Path.IO import qualified Paths_stack as Meta -import Stack.BuildPlan import Stack.Config.Build import Stack.Config.Docker import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants +import Stack.Fetch import qualified Stack.Image as Image +import Stack.Package +import Stack.PackageLocation +import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Internal import Stack.Types.Nix +import Stack.Types.PackageName (PackageName) +import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex (IndexType (ITHackageSecurity), HackageSecurity (..)) import Stack.Types.Resolver import Stack.Types.StackT @@ -107,11 +104,9 @@ import Stack.Types.StringError import Stack.Types.Urls import Stack.Types.Version import System.Environment -import System.IO import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import System.Process.Read -import System.Process.Run -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -184,14 +179,15 @@ getSnapshots = do -- | Turn an 'AbstractResolver' into a 'Resolver'. makeConcreteResolver :: (StackMiniM env m, HasConfig env) - => AbstractResolver + => Maybe (Path Abs Dir) -- ^ root of project for resolving custom relative paths + -> AbstractResolver -> m Resolver -makeConcreteResolver (ARResolver r) = return r -makeConcreteResolver ar = do +makeConcreteResolver root (ARResolver r) = parseCustomLocation root r +makeConcreteResolver root ar = do snapshots <- getSnapshots r <- case ar of - ARResolver r -> assert False $ return r + ARResolver r -> assert False $ makeConcreteResolver root $ ARResolver r ARGlobal -> do config <- view configL implicitGlobalDir <- getImplicitGlobalProjectDir config @@ -209,11 +205,11 @@ makeConcreteResolver ar = do | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots in return $ ResolverSnapshot $ LTS x y - $logInfo $ "Selected resolver: " <> resolverName r + $logInfo $ "Selected resolver: " <> resolverRawName r return r -- | Get the latest snapshot resolver available. -getLatestResolver :: (StackMiniM env m, HasConfig env) => m Resolver +getLatestResolver :: (StackMiniM env m, HasConfig env) => m (ResolverWith a) getLatestResolver = do snapshots <- getSnapshots let mlts = do @@ -225,14 +221,14 @@ getLatestResolver = do -- | 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) + :: (MonadLogger m, MonadUnliftIO m, MonadThrow m) => Path Abs Dir -- ^ stack root -> Maybe AbstractResolver -> ConfigMonoid -> m Config -configNoLocalConfig _ Nothing _ = throwM NoResolverWhenUsingNoLocalConfig +configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig configNoLocalConfig stackRoot (Just resolver) configMonoid = do - userConfigPath <- getFakeConfigPath stackRoot resolver + userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver configFromConfigMonoid stackRoot userConfigPath @@ -243,7 +239,7 @@ configNoLocalConfig stackRoot (Just resolver) configMonoid = do -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadLogger m, MonadIO m, MonadCatch m) + :: (MonadLogger m, MonadUnliftIO m, MonadThrow m) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Bool -- ^ allow locals? @@ -257,7 +253,7 @@ configFromConfigMonoid -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" mstackWorkEnv <- liftIO $ lookupEnv stackWorkEnvVar - configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) parseRelDir mstackWorkEnv + configWorkDir0 <- maybe (return $(mkRelDir ".stack-work")) (liftIO . parseRelDir) mstackWorkEnv let configWorkDir = fromFirst configWorkDir0 configMonoidWorkDir -- This code is to handle the deprecation of latest-snapshot-url configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of @@ -365,8 +361,8 @@ configFromConfigMonoid -- TODO: Either catch specific exceptions or add a -- parseRelAsAbsDirMaybe utility and use it along with -- resolveDirMaybe. - `catchAll` - const (throwM (NoSuchDirectory userPath)) + `catchAny` + const (throwIO (NoSuchDirectory userPath)) configJobs <- case getFirst configMonoidJobs of @@ -378,7 +374,7 @@ configFromConfigMonoid configScmInit = getFirst configMonoidScmInit configGhcOptions = configMonoidGhcOptions configSetupInfoLocations = configMonoidSetupInfoLocations - configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds + configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds configModifyCodePage = fromFirst True configMonoidModifyCodePage configExplicitSetupDeps = configMonoidExplicitSetupDeps configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions @@ -386,6 +382,7 @@ configFromConfigMonoid configAllowNewer = fromFirst False configMonoidAllowNewer configDefaultTemplate = getFirst configMonoidDefaultTemplate configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs + configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of @@ -514,11 +511,12 @@ loadConfig configArgs mresolver mstackYaml = -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. -loadBuildConfig :: StackM env m +loadBuildConfig :: forall env m. + StackM env m => LocalConfigStatus (Project, Path Abs File, ConfigMonoid) -> Config -> Maybe AbstractResolver -- override resolver - -> Maybe CompilerVersion -- override compiler + -> Maybe (CompilerVersion 'CVWanted) -- override compiler -> m BuildConfig loadBuildConfig mproject config mresolver mcompiler = do env <- ask @@ -545,12 +543,12 @@ loadBuildConfig mproject config mresolver mcompiler = do when (view terminalL env) $ case mresolver of Nothing -> - $logDebug ("Using resolver: " <> resolverName (projectResolver project) <> + $logDebug ("Using resolver: " <> resolverRawName (projectResolver project) <> " from implicit global project's config file: " <> T.pack dest') Just aresolver -> do let name = case aresolver of - ARResolver resolver -> resolverName resolver + ARResolver resolver -> resolverRawName resolver ARLatestNightly -> "nightly" ARLatestLTS -> "lts" ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x @@ -581,27 +579,23 @@ loadBuildConfig mproject config mresolver mcompiler = do case mresolver of Nothing -> return $ projectResolver project' Just aresolver -> - runReaderT (makeConcreteResolver aresolver) miniConfig + runReaderT (makeConcreteResolver (Just (parent stackYamlFP)) aresolver) miniConfig let project = project' { projectResolver = resolver , projectCompiler = mcompiler <|> projectCompiler project' } - (mbp0, loadedResolver) <- flip runReaderT miniConfig $ - loadResolver (Just stackYamlFP) (projectResolver project) - let mbp = case projectCompiler project of - Just compiler -> mbp0 { mbpCompilerVersion = compiler } - Nothing -> mbp0 + sd0 <- flip runReaderT miniConfig $ loadResolver resolver + let sd = maybe id setCompilerVersion (projectCompiler project) sd0 extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) return BuildConfig { bcConfig = config - , bcResolver = loadedResolver - , bcWantedMiniBuildPlan = mbp + , bcSnapshotDef = sd , bcGHCVariant = view ghcVariantL miniConfig - , bcPackageEntries = projectPackages project - , bcExtraDeps = projectExtraDeps project + , bcPackages = projectPackages project + , bcDependencies = projectDependencies project , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project @@ -614,20 +608,21 @@ loadBuildConfig mproject config mresolver mcompiler = do where miniConfig = loadMiniConfig config + getEmptyProject :: m Project getEmptyProject = do r <- case mresolver of Just aresolver -> do - r' <- runReaderT (makeConcreteResolver aresolver) miniConfig - $logInfo ("Using resolver: " <> resolverName r' <> " specified on command line") + r' <- runReaderT (makeConcreteResolver Nothing aresolver) miniConfig + $logInfo ("Using resolver: " <> resolverRawName r' <> " specified on command line") return r' Nothing -> do r'' <- runReaderT getLatestResolver miniConfig - $logInfo ("Using latest snapshot resolver: " <> resolverName r'') + $logInfo ("Using latest snapshot resolver: " <> resolverRawName r'') return r'' return Project { projectUserMsg = Nothing - , projectPackages = mempty - , projectExtraDeps = mempty + , projectPackages = [] + , projectDependencies = [] , projectFlags = mempty , projectResolver = r , projectCompiler = Nothing @@ -637,174 +632,103 @@ loadBuildConfig mproject config mresolver mcompiler = do -- | 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) + :: forall env m. + (StackMiniM env m, HasEnvConfig env) + => m LocalPackages getLocalPackages = do cacheRef <- view $ envConfigL.to envConfigPackagesRef mcached <- liftIO $ readIORef cacheRef case mcached of Just cached -> return cached - Nothing -> do + Nothing -> withCabalLoader $ \loadFromIndex -> do menv <- getMinimalEnvOverride root <- view projectRootL - entries <- view $ buildConfigL.to bcPackageEntries - liftM (Map.fromList . concat) $ mapM - (resolvePackageEntry menv root) - entries - --- | Resolve a PackageEntry into a list of paths, downloading and cloning as --- necessary. -resolvePackageEntry - :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ project root - -> PackageEntry - -> m [(Path Abs Dir, TreatLikeExtraDep)] -resolvePackageEntry menv projRoot pe = do - entryRoot <- resolvePackageLocation menv projRoot (peLocation pe) - paths <- - case peSubdirs pe of - [] -> return [entryRoot] - subs -> mapM (resolveDir entryRoot) subs - extraDep <- - case peExtraDepMaybe pe of - Just e -> return e - Nothing -> - case peLocation pe of - PLFilePath _ -> - -- we don't give a warning on missing explicit - -- value here, user intent is almost always - -- the default for a local directory - return False - PLRemote url _ -> do - $logWarn $ mconcat - [ "No extra-dep setting found for package at URL:\n\n" - , url - , "\n\n" - , "This is usually a mistake, external packages " - , "should typically\nbe treated as extra-deps to avoid " - , "spurious test case failures." - ] - return False - return $ map (, extraDep) paths - --- | Resolve a PackageLocation into a path, downloading and cloning as --- necessary. -resolvePackageLocation - :: (StackMiniM env m, HasConfig env) - => EnvOverride - -> Path Abs Dir -- ^ project root - -> PackageLocation - -> m (Path Abs Dir) -resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp -resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do - 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 $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing - root = projRoot workDir $(mkRelDir "downloaded") - fileExtension' = case remotePackageType of - RPTHttp -> ".http-archive" - _ -> ".unused" - - fileRel <- parseRelFile $ name ++ fileExtension' - dirRel <- parseRelDir name - dirRelTmp <- parseRelDir $ name ++ ".tmp" - let file = root fileRel - dir = root dirRel - - exists <- doesDirExist dir - unless exists $ do - ignoringAbsence (removeDirRecur dir) - - let cloneAndExtract commandName cloneArgs resetCommand commit = do - ensureDir root - callProcessInheritStderrStdout Cmd - { cmdDirectoryToRunIn = Just root - , cmdCommandToRun = commandName - , cmdEnvOverride = menv - , cmdCommandLineArguments = - "clone" : - cloneArgs ++ - [ T.unpack url - , toFilePathNoTrailingSep dir - ] - } - created <- doesDirExist dir - unless created $ throwM $ FailedToCloneRepo commandName - readProcessNull (Just dir) menv commandName - (resetCommand ++ [T.unpack commit, "--"]) - `catch` \case - ex@ProcessFailed{} -> do - $logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url - throwM ex - ex -> throwM ex - - case remotePackageType of - RPTHttp -> do - let dirTmp = root dirRelTmp - ignoringAbsence (removeDirRecur dirTmp) - - let fp = toFilePath file - req <- parseUrlThrow $ T.unpack url - _ <- download req file - - let tryTar = do - $logDebug $ "Trying to untar " <> T.pack fp - liftIO $ withBinaryFile fp ReadMode $ \h -> do - lbs <- L.hGetContents h - let entries = Tar.read $ GZip.decompress lbs - Tar.unpack (toFilePath dirTmp) entries - tryZip = do - $logDebug $ "Trying to unzip " <> T.pack fp - archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp - liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination - (toFilePath dirTmp)] archive - err = throwM $ UnableToExtractArchive url file - - catchAllLog goodpath handler = - catchAll goodpath $ \e -> do - $logDebug $ "Got exception: " <> T.pack (show e) - handler - - tryTar `catchAllLog` tryZip `catchAllLog` err - renameDir dirTmp dir - - -- Passes in --git-dir to git and --repository to hg, in order - -- to avoid the update commands being applied to the user's - -- repo. See https://github.com/commercialhaskell/stack/issues/2748 - RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] commit - RPTHg commit -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] commit - - case remotePackageType of - RPTHttp -> do - x <- listDir dir - case x of - ([dir'], []) -> return dir' - (dirs, files) -> do - ignoringAbsence (removeFile file) - ignoringAbsence (removeDirRecur dir) - throwM $ UnexpectedArchiveContents dirs files - _ -> return dir + bc <- view buildConfigL + + packages <- do + bss <- concat <$> mapM (loadMultiRawCabalFiles menv root) (bcPackages bc) + forM bss $ \(bs, loc) -> do + (warnings, gpd) <- + case rawParseGPD bs of + Left e -> throwM $ InvalidCabalFileInLocal (PLOther loc) e bs + Right x -> return x + let PackageIdentifier name version = + fromCabalPackageIdentifier + $ C.package + $ C.packageDescription gpd + dir <- resolveSinglePackageLocation menv root loc + cabalfp <- findOrGenerateCabalFile dir + mapM_ (printCabalFileWarning cabalfp) warnings + checkCabalFileName name cabalfp + let lpv = LocalPackageView + { lpvVersion = version + , lpvRoot = dir + , lpvCabalFP = cabalfp + , lpvComponents = getNamedComponents gpd + , lpvGPD = gpd + , lpvLoc = loc + } + return (name, lpv) + + deps <- mapM (loadMultiRawCabalFilesIndex loadFromIndex menv root) (bcDependencies bc) + >>= mapM (\(bs, loc :: PackageLocationIndex FilePath) -> do + (_warnings, gpd) <- do + case rawParseGPD bs of + Left e -> throwM $ InvalidCabalFileInLocal loc e bs + Right x -> return x + let PackageIdentifier name _version = + fromCabalPackageIdentifier + $ C.package + $ C.packageDescription gpd + return (name, (gpd, loc))) . concat + + checkDuplicateNames $ + map (second (PLOther . lpvLoc)) packages ++ + map (second snd) deps + + return LocalPackages + { lpProject = Map.fromList packages + , lpDependencies = Map.fromList deps + } + where + getNamedComponents gpkg = Set.fromList $ concat + [ maybe [] (const [CLib]) (C.condLibrary gpkg) + , go CExe (map fst . C.condExecutables) + , go CTest (map fst . C.condTestSuites) + , go CBench (map fst . C.condBenchmarks) + ] + where + go :: (T.Text -> NamedComponent) + -> (C.GenericPackageDescription -> [String]) + -> [NamedComponent] + go wrapper f = map (wrapper . T.pack) $ f gpkg + +-- | Check if there are any duplicate package names and, if so, throw an +-- exception. +checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m () +checkDuplicateNames locals = + case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map (second return) locals of + [] -> return () + x -> throwM $ DuplicateLocalPackageNames x + where + hasMultiples (_, _:_:_) = True + hasMultiples _ = False -- | Get the stack root, e.g. @~/.stack@, and determine whether the user owns it. -- -- On Windows, the second value is always 'True'. determineStackRootAndOwnership - :: (MonadIO m, MonadCatch m) + :: (MonadIO m) => ConfigMonoid -- ^ Parsed command-line arguments -> m (Path Abs Dir, Bool) -determineStackRootAndOwnership clArgs = do +determineStackRootAndOwnership clArgs = liftIO $ do stackRoot <- do case getFirst (configMonoidStackRoot clArgs) of Just x -> return x Nothing -> do - mstackRoot <- liftIO $ lookupEnv stackRootEnvVar + mstackRoot <- lookupEnv stackRootEnvVar case mstackRoot of Nothing -> getAppUserDataDir stackProgName Just x -> case parseAbsDir x of @@ -815,12 +739,12 @@ determineStackRootAndOwnership clArgs = do mdirAndOwnership <- findInParents getDirAndOwnership stackRoot case mdirAndOwnership of Just x -> return x - Nothing -> throwM (BadStackRoot stackRoot) + Nothing -> throwIO (BadStackRoot stackRoot) when (existingStackRootOrParentDir /= stackRoot) $ if userOwnsIt - then liftIO $ ensureDir stackRoot - else throwM $ + then ensureDir stackRoot + else throwIO $ Won'tCreateStackRootInDirectoryOwnedByDifferentUser stackRoot existingStackRootOrParentDir @@ -834,22 +758,22 @@ determineStackRootAndOwnership clArgs = do -- If @dir@ doesn't exist, its parent directory is checked instead. -- If the parent directory doesn't exist either, @'NoSuchDirectory' ('parent' dir)@ -- is thrown. -checkOwnership :: (MonadIO m, MonadCatch m) => Path Abs Dir -> m () +checkOwnership :: (MonadIO m) => Path Abs Dir -> m () checkOwnership dir = do mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir] case mdirAndOwnership of Just (_, True) -> return () - Just (dir', False) -> throwM (UserDoesn'tOwnDirectory dir') + Just (dir', False) -> throwIO (UserDoesn'tOwnDirectory dir') Nothing -> - (throwM . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir + (throwIO . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir -- | @'getDirAndOwnership' dir@ returns @'Just' (dir, 'True')@ when @dir@ -- exists and the current user owns it in the sense of 'isOwnedByUser'. getDirAndOwnership - :: (MonadIO m, MonadCatch m) + :: (MonadIO m) => Path Abs Dir -> m (Maybe (Path Abs Dir, Bool)) -getDirAndOwnership dir = forgivingAbsence $ do +getDirAndOwnership dir = liftIO $ forgivingAbsence $ do ownership <- isOwnedByUser dir return (dir, ownership) @@ -1029,7 +953,7 @@ getFakeConfigPath getFakeConfigPath stackRoot ar = do asString <- case ar of - ARResolver r -> return $ T.unpack $ resolverName r + ARResolver r -> return $ T.unpack $ resolverRawName r _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar asDir <- parseRelDir asString let full = stackRoot $(mkRelDir "script") asDir $(mkRelFile "config.yaml") diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index b8e37a95aa..fe735668dd 100644 --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -3,8 +3,8 @@ -- | Docker configuration module Stack.Config.Docker where -import Control.Exception.Lifted -import Control.Monad.Catch (MonadThrow) +import Control.Monad (void) +import Control.Monad.IO.Unlift import Data.List (find) import Data.Maybe import Data.Monoid.Extra @@ -12,7 +12,6 @@ import qualified Data.Text as T import Data.Typeable (Typeable) import Distribution.Version (simplifyVersionRange) import Path -import Stack.Types.BuildPlan import Stack.Types.Version import Stack.Types.Config import Stack.Types.Docker @@ -33,13 +32,13 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do let mresolver = case maresolver of Just (ARResolver resolver) -> - Just resolver + Just (void resolver) Just aresolver -> - throw + impureThrow (ResolverNotSupportedException $ show aresolver) Nothing -> - fmap projectResolver mproject + fmap (void . projectResolver) mproject defaultTag = case mresolver of Nothing -> "" @@ -48,7 +47,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do ResolverSnapshot n@(LTS _ _) -> ":" ++ T.unpack (renderSnapName n) _ -> - throw + impureThrow (ResolverNotSupportedException $ show resolver) in case getFirst dockerMonoidRepoOrImage of @@ -78,6 +77,7 @@ dockerOptsFromMonoid mproject stackRoot maresolver DockerOptsMonoid{..} = do simplifyVersionRange (getIntersectingVersionRange dockerMonoidRequireDockerVersion) dockerDatabasePath = fromFirst (stackRoot $(mkRelFile "docker.db")) dockerMonoidDatabasePath dockerStackExe = getFirst dockerMonoidStackExe + return DockerOpts{..} where emptyToNothing Nothing = Nothing emptyToNothing (Just s) | null s = Nothing diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs index 1025bb6534..e7d2acc8ad 100644 --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -8,6 +8,7 @@ module Stack.Config.Nix ) where import Control.Monad (when) +import Control.Monad.IO.Unlift import Data.Maybe import Data.Monoid.Extra import qualified Data.Text as T @@ -17,13 +18,11 @@ import Stack.Types.Version import Stack.Types.Nix import Stack.Types.Compiler import Stack.Types.StringError -import Control.Exception.Lifted -import Control.Monad.Catch (throwM,MonadCatch) import Prelude -- | Interprets NixOptsMonoid options. nixOptsFromMonoid - :: (Monad m, MonadCatch m) + :: MonadUnliftIO m => NixOptsMonoid -> OS -> m NixOpts @@ -39,12 +38,12 @@ nixOptsFromMonoid NixOptsMonoid{..} os = do ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath) nixAddGCRoots = fromFirst False nixMonoidAddGCRoots when (not (null nixPackages) && isJust nixInitFile) $ - throwM NixCannotUseShellFileAndPackagesException + throwIO NixCannotUseShellFileAndPackagesException return NixOpts{..} where prefixAll p (x:xs) = p : x : prefixAll p xs prefixAll _ _ = [] -nixCompiler :: CompilerVersion -> T.Text +nixCompiler :: CompilerVersion a -> T.Text nixCompiler compilerVersion = let -- These are the latest minor versions for each respective major version available in nixpkgs fixMinor "8.0" = "8.0.1" diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index c4c80941e1..dcd477685b 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -15,8 +15,7 @@ module Stack.ConfigCmd import Control.Applicative import Control.Monad -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap @@ -29,9 +28,9 @@ 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, getProjectConfig, getImplicitGlobalProjectDir, LocalConfigStatus(..)) import Stack.Constants +import Stack.Snapshot (loadResolver) import Stack.Types.Config import Stack.Types.Resolver import Stack.Types.StringError @@ -61,9 +60,7 @@ cfgCmdSet cfgCmdSet go cmd = do conf <- view configL configFilePath <- - liftM - toFilePath - (case configCmdSetScope cmd of + case configCmdSetScope cmd of CommandScopeProject -> do mstackYamlOption <- forM (globalStackYaml go) resolveFile' mstackYaml <- getProjectConfig mstackYamlOption @@ -71,36 +68,33 @@ cfgCmdSet go cmd = do LCSProject stackYaml -> return stackYaml LCSNoProject -> liftM ( stackDotYaml) (getImplicitGlobalProjectDir conf) LCSNoConfig -> errorString "config command used when no local configuration available" - CommandScopeGlobal -> return (configUserConfigPath conf)) + 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 - newValue <- cfgCmdSetValue cmd + liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>= either throwM return + newValue <- cfgCmdSetValue (parent configFilePath) cmd let cmdKey = cfgCmdSetOptionName cmd config' = HMap.insert cmdKey newValue config if config' == config then $logInfo - (T.pack configFilePath <> + (T.pack (toFilePath configFilePath) <> " already contained the intended configuration and remains unchanged.") else do - liftIO (S.writeFile configFilePath (Yaml.encode config')) - $logInfo (T.pack configFilePath <> " has been updated.") + liftIO (S.writeFile (toFilePath configFilePath) (Yaml.encode config')) + $logInfo (T.pack (toFilePath configFilePath) <> " has been updated.") cfgCmdSetValue :: (StackMiniM env m, HasConfig env, HasGHCVariant env) - => ConfigCmdSet -> m Yaml.Value -cfgCmdSetValue (ConfigCmdSetResolver newResolver) = do - concreteResolver <- makeConcreteResolver newResolver - case concreteResolver of - -- Check that the snapshot actually exists - ResolverSnapshot snapName -> void $ loadMiniBuildPlan snapName - ResolverCompiler _ -> return () - -- TODO: custom snapshot support? Would need a way to specify on CLI - ResolverCustom _ _ -> errorString "'stack config set resolver' does not support custom resolvers" - return (Yaml.String (resolverName concreteResolver)) -cfgCmdSetValue (ConfigCmdSetSystemGhc _ bool) = + => Path Abs Dir -- ^ root directory of project + -> ConfigCmdSet -> m Yaml.Value +cfgCmdSetValue root (ConfigCmdSetResolver newResolver) = do + concreteResolver <- makeConcreteResolver (Just root) newResolver + -- Check that the snapshot actually exists + void $ loadResolver concreteResolver + return (Yaml.toJSON concreteResolver) +cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool) = return (Yaml.Bool bool) -cfgCmdSetValue (ConfigCmdSetInstallGhc _ bool) = +cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool) = return (Yaml.Bool bool) cfgCmdSetOptionName :: ConfigCmdSet -> Text diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 0f849468cb..be52c99859 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -43,7 +43,7 @@ module Stack.Constants ) where -import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Unlift import Control.Monad.Reader import Data.Char (toUpper) import Data.HashSet (HashSet) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index 0948d69483..f70c1c8813 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -16,12 +16,9 @@ module Stack.Coverage , generateHpcMarkupIndex ) where -import Control.Exception.Safe (handleIO) -import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void, (<=<)) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Resource import qualified Data.ByteString.Char8 as S8 import Data.Foldable (forM_, asum, toList) import Data.Function @@ -41,7 +38,6 @@ import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude hiding (FilePath, writeFile) -import Stack.Build.Source (parseTargetsFromBuildOpts) import Stack.Build.Target import Stack.Config (getLocalPackages) import Stack.Constants @@ -66,7 +62,7 @@ deleteHpcReports :: (StackM env m, HasEnvConfig env) => m () deleteHpcReports = do hpcDir <- hpcReportDir - ignoringAbsence (removeDirRecur hpcDir) + liftIO $ ignoringAbsence (removeDirRecur hpcDir) -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. @@ -76,7 +72,7 @@ updateTixFile pkgName tixSrc testName = do exists <- doesFileExist tixSrc when exists $ do tixDest <- tixFilePath pkgName testName - ignoringAbsence (removeFile tixDest) + liftIO $ ignoringAbsence (removeFile tixDest) ensureDir (parent tixDest) -- Remove exe modules because they are problematic. This could be revisited if there's a GHC -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853 @@ -89,7 +85,7 @@ updateTixFile pkgName tixSrc testName = do -- have problems. Something about moving between drives -- on windows? copyFile tixSrc =<< parseAbsFile (toFilePath tixDest ++ ".premunging") - ignoringAbsence (removeFile tixSrc) + liftIO $ ignoringAbsence (removeFile tixSrc) -- | Get the directory used for hpc reports for the given pkgId. hpcPkgPath :: (StackM env m, HasEnvConfig env) @@ -174,7 +170,7 @@ generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArg -- Directories for .mix files. hpcRelDir <- hpcRelativeDir -- Compute arguments used for both "hpc markup" and "hpc report". - pkgDirs <- liftM Map.keys getLocalPackages + pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages let args = -- Use index files from all packages (allows cross-package coverage results). concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++ @@ -237,19 +233,17 @@ generateHpcReportForTargets opts = do else do when (hroptsAll opts && not (null targetNames)) $ $logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames) - (_,_,targets) <- parseTargetsFromBuildOpts + (_,_,targets) <- parseTargets AllowNoTargets defaultBuildOptsCLI { boptsCLITargets = if hroptsAll opts then [] else targetNames } liftM concat $ forM (Map.toList targets) $ \(name, target) -> case target of - STUnknown -> throwString $ - "Error: " ++ packageNameString name ++ " isn't a known local page" - STNonLocal -> throwString $ + TargetAll Dependency -> throwString $ "Error: Expected a local package, but " ++ packageNameString name ++ " is either an extra-dep or in the snapshot." - STLocalComps comps -> do + TargetComps comps -> do pkgPath <- hpcPkgPath name forM (toList comps) $ \nc -> case nc of @@ -259,7 +253,7 @@ generateHpcReportForTargets opts = do "Can't specify anything except test-suites as hpc report targets (" ++ packageNameString name ++ " is used with a non test-suite target)" - STLocalAll -> do + TargetAll ProjectPackage -> do pkgPath <- hpcPkgPath name exists <- doesDirExist pkgPath if exists @@ -327,7 +321,7 @@ generateUnionReport report reportDir tixFiles = do liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] -readTixOrLog :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) => Path b File -> m (Maybe Tix) +readTixOrLog :: (MonadLogger m, MonadUnliftIO m) => Path b File -> m (Maybe Tix) readTixOrLog path = do mtix <- liftIO (readTix (toFilePath path)) `catch` \errorCall -> do $logError $ "Error while reading tix: " <> T.pack (show (errorCall :: ErrorCall)) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 8a331e7504..01380287a6 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -21,14 +21,10 @@ module Stack.Docker ) where import Control.Applicative -import Control.Concurrent.MVar.Lifted (MVar,modifyMVar_,newMVar) -import Control.Exception.Lifted import Control.Monad -import Control.Monad.Catch (MonadThrow,throwM,MonadCatch) -import Control.Monad.IO.Class (MonadIO,liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn) import Control.Monad.Reader (MonadReader,runReaderT) -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Writer (execWriter,runWriter,tell) import qualified Crypto.Hash as Hash (Digest, MD5, hash) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) @@ -82,7 +78,6 @@ import Text.Printf (printf) #ifndef WINDOWS import Control.Concurrent (threadDelay) -import qualified Control.Monad.Trans.Control as Control import System.Posix.Signals import qualified System.Posix.User as PosixUser #endif @@ -91,7 +86,7 @@ import qualified System.Posix.User as PosixUser -- Otherwise, runs the inner action. -- -- This takes an optional release action which should be taken IFF control is --- transfering away from the current process to the intra-container one. The main use +-- transferring away from the current process to the intra-container one. The main use -- for this is releasing a lock. After launching reexecution, the host process becomes -- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalContainer @@ -129,7 +124,7 @@ reexecWithOptionalContainer mprojectRoot = | configPlatform config == dockerContainerPlatform -> do exePath <- liftIO getExecutablePath cmdArgs args exePath - | otherwise -> throwM UnsupportedStackExeHostPlatformException + | otherwise -> throwIO UnsupportedStackExeHostPlatformException Just DockerStackExeImage -> do progName <- liftIO getProgName return (FP.takeBaseName progName, args, [], []) @@ -210,7 +205,7 @@ execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease inContainer <- getInContainer isReExec <- view reExecL if | inContainer && not isReExec && (isJust mbefore || isJust mafter) -> - throwM OnlyOnHostException + throwIO OnlyOnHostException | inContainer -> liftIO (do inner exitSuccess) @@ -231,11 +226,11 @@ execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease fromMaybeAction (Just hook) = hook -- | Error if running in a container. -preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m () +preventInContainer :: MonadIO m => m () -> m () preventInContainer inner = do inContainer <- getInContainer if inContainer - then throwM OnlyOnHostException + then throwIO OnlyOnHostException else inner -- | Run a command in a new Docker container, then exit the process. @@ -364,7 +359,7 @@ runContainerAndExit getCmdArgs ,args]) before #ifndef WINDOWS - runInBase <- Control.liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do let sigHandler = runInBase $ do readProcessNull Nothing envOverride "docker" @@ -495,12 +490,12 @@ cleanup opts = | repo == "" -> (hash,[]) | tag == "" -> (hash,[repo]) | otherwise -> (hash,[repo ++ ":" ++ tag]) - _ -> throw (InvalidImagesOutputException line) + _ -> impureThrow (InvalidImagesOutputException line) parseContainersOut = map parseContainer . drop 1 . lines . decodeUtf8 where parseContainer line = case words line of hash:image:rest -> (hash,(image,last rest)) - _ -> throw (InvalidPSOutputException line) + _ -> impureThrow (InvalidPSOutputException line) buildPlan curTime imagesLastUsed imageRepos @@ -641,17 +636,17 @@ cleanup opts = containerStr = "container" -- | Inspect Docker image or container. -inspect :: (MonadIO m,MonadLogger m,MonadBaseControl IO m,MonadCatch m) +inspect :: (MonadUnliftIO m,MonadLogger m) => EnvOverride -> String -> m (Maybe Inspect) inspect envOverride image = do results <- inspects envOverride [image] case Map.toList results of [] -> return Nothing [(_,i)] -> return (Just i) - _ -> throwM (InvalidInspectOutputException "expect a single result") + _ -> throwIO (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers. -inspects :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +inspects :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> [String] -> m (Map String Inspect) inspects _ [] = return Map.empty inspects envOverride images = @@ -661,11 +656,11 @@ inspects envOverride images = Right inspectOut -> -- filtering with 'isAscii' to workaround @docker inspect@ output containing invalid UTF-8 case eitherDecode (LBS.pack (filter isAscii (decodeUtf8 inspectOut))) of - Left msg -> throwM (InvalidInspectOutputException msg) + Left msg -> throwIO (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) Left (ProcessFailed _ _ _ err) | "Error: No such image" `LBS.isPrefixOf` err -> return Map.empty - Left e -> throwM e + Left e -> throwIO e -- | Pull latest version of configured Docker image from registry. pull :: (StackM env m, HasConfig env) => m () @@ -706,30 +701,30 @@ pullImage envOverride docker image = ec <- liftIO (waitForProcess ph) case ec of ExitSuccess -> return () - ExitFailure _ -> throwM (PullFailedException image) + ExitFailure _ -> throwIO (PullFailedException image) -- | Check docker version (throws exception if incorrect) checkDockerVersion - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> DockerOpts -> m () checkDockerVersion envOverride docker = do dockerExists <- doesExecutableExist envOverride "docker" - unless dockerExists (throwM DockerNotInstalledException) + unless dockerExists (throwIO DockerNotInstalledException) dockerVersionOut <- readDockerProcess envOverride Nothing ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> case parseVersionFromString (stripVersion v) of Just v' | v' < minimumDockerVersion -> - throwM (DockerTooOldException minimumDockerVersion v') + throwIO (DockerTooOldException minimumDockerVersion v') | v' `elem` prohibitedDockerVersions -> - throwM (DockerVersionProhibitedException prohibitedDockerVersions v') + throwIO (DockerVersionProhibitedException prohibitedDockerVersions v') | not (v' `withinRange` dockerRequireDockerVersion docker) -> - throwM (BadDockerVersionException (dockerRequireDockerVersion docker) v') + throwIO (BadDockerVersionException (dockerRequireDockerVersion docker) v') | otherwise -> return () - _ -> throwM InvalidVersionOutputException - _ -> throwM InvalidVersionOutputException + _ -> throwIO InvalidVersionOutputException + _ -> throwIO InvalidVersionOutputException where minimumDockerVersion = $(mkVersion "1.6.0") prohibitedDockerVersions = [] stripVersion v = takeWhile (/= '-') (dropWhileEnd (not . isDigit) v) @@ -747,14 +742,14 @@ reset maybeProjectRoot keepHome = do -- | The Docker container "entrypoint": special actions performed when first entering -- a container, such as switching the UID/GID to the "outside-Docker" user's. -entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) +entrypoint :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) => Config -> DockerEntrypoint -> m () entrypoint config@Config{..} DockerEntrypoint{..} = modifyMVar_ entrypointMVar $ \alreadyRan -> do -- Only run the entrypoint once unless alreadyRan $ do envOverride <- getEnvOverride configPlatform - homeDir <- parseAbsDir =<< liftIO (getEnv "HOME") + homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME" -- Get the UserEntry for the 'stack' user in the image, if it exists estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ User.getUserEntryForName stackUserName @@ -768,7 +763,7 @@ entrypoint config@Config{..} DockerEntrypoint{..} = Right ue -> do -- If the 'stack' user exists in the image, copy any build plans and package indices from -- its original home directory to the host's stack root, to avoid needing to download them - origStackHomeDir <- parseAbsDir (User.homeDirectory ue) + origStackHomeDir <- liftIO $ parseAbsDir (User.homeDirectory ue) let origStackRoot = origStackHomeDir $(mkRelDir ("." ++ stackProgName)) buildPlanDirExists <- doesDirExist (buildPlanDir origStackRoot) when buildPlanDirExists $ do @@ -865,7 +860,7 @@ removeDirectoryContents path excludeDirs excludeFiles = -- process. Throws a 'ReadProcessException' exception if the -- process fails. Logs process's stderr using @$logError@. readDockerProcess - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> Maybe (Path Abs Dir) -> [String] -> m BS.ByteString readDockerProcess envOverride mpwd = readProcessStdout mpwd envOverride "docker" @@ -887,7 +882,7 @@ concatT = T.pack . concat -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir -fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException) +fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRootException) -- | Environment variable that contained the old sandbox ID. -- | Use of this variable is deprecated, and only used to detect old images. diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs index 25ad081ed3..e0e5cabd54 100644 --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -15,10 +15,9 @@ module Stack.Docker.GlobalDB ,DockerImageExeId) where -import Control.Exception (IOException,catch,throwIO) import Control.Monad (forM_, when) import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.IO.Unlift import Data.List (sortBy, isInfixOf, stripPrefix) import Data.List.Extra (stripSuffix) import qualified Data.Map.Strict as Map diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 1bf5aee78f..753942c3c3 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -18,7 +18,6 @@ import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad (liftM, void) import Control.Monad.IO.Class -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.Map (Map) @@ -37,10 +36,12 @@ import Stack.Build (withLoadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source import Stack.Build.Target +import Stack.Config (getLocalPackages) import Stack.Constants import Stack.Package import Stack.PackageDump (DumpPackage(..)) import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId @@ -80,7 +81,7 @@ data ListDepsOpts = ListDepsOpts } -- | Visualize the project's dependencies as a graphviz graph -dot :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +dot :: (StackM env m, HasEnvConfig env) => DotOpts -> m () dot dotOpts = do @@ -98,12 +99,12 @@ data DotPayload = DotPayload -- | Create the dependency graph and also prune it as specified in the dot -- options. Returns a set of local names and and a map from package names to -- dependencies. -createPrunedDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +createPrunedDependencyGraph :: (StackM env m, HasEnvConfig env) => DotOpts -> m (Set PackageName, Map PackageName (Set PackageName, DotPayload)) createPrunedDependencyGraph dotOpts = do - localNames <- liftM Map.keysSet getLocalPackageViews + localNames <- liftM (Map.keysSet . lpProject) getLocalPackages resultGraph <- createDependencyGraph dotOpts let pkgsToPrune = if dotIncludeBase dotOpts then dotPrune dotOpts @@ -115,11 +116,11 @@ createPrunedDependencyGraph dotOpts = do -- name to a tuple of dependencies and payload if available. This -- function mainly gathers the required arguments for -- @resolveDependencies@. -createDependencyGraph :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +createDependencyGraph :: (StackM env m, HasEnvConfig env) => DotOpts -> m (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do - (_, _, locals, _, _, sourceMap) <- loadSourceMapFull NeedTargets defaultBuildOptsCLI + (locals, sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI { boptsCLITargets = dotTargets dotOpts , boptsCLIFlags = dotFlags dotOpts } @@ -134,17 +135,16 @@ createDependencyGraph dotOpts = do globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump withLoadPackage (\loader -> do let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps - loadPackageDeps name version flags ghcOptions + loadPackageDeps name version loc 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) + | otherwise = fmap (packageAllDeps &&& makePayload) (loader loc flags ghcOptions) liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) -listDependencies :: (StackM env m, HasEnvConfig env, MonadBaseUnlift IO m) +listDependencies :: (StackM env m, HasEnvConfig env) => ListDepsOpts -> m () listDependencies opts = do @@ -215,7 +215,8 @@ createDepLoader :: Applicative m -> Map PackageName (InstallLocation, Installed) -> Map PackageName (DumpPackage () () ()) -> Map GhcPkgId PackageIdentifier - -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) + -> (PackageName -> Version -> PackageLocationIndex FilePath -> + Map FlagName Bool -> [Text] -> m (Set PackageName, DotPayload)) -> PackageName -> m (Set PackageName, DotPayload) createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pkgName = @@ -224,8 +225,8 @@ createDepLoader sourceMap installed globalDumpMap globalIdMap loadPackageDeps pk Just (PSLocal lp) -> pure (packageAllDeps pkg, payloadFromLocal pkg) where pkg = localPackageToPackage lp - Just (PSUpstream version _ flags ghcOptions _) -> - loadPackageDeps pkgName version flags ghcOptions + Just (PSUpstream version _ flags ghcOptions loc) -> + loadPackageDeps pkgName version loc flags ghcOptions Nothing -> pure (Set.empty, payloadFromInstalled (Map.lookup pkgName installed)) -- For wired-in-packages, use information from ghc-pkg (see #3084) else case Map.lookup pkgName globalDumpMap of diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 7b95b9ca78..9a8d485623 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -12,13 +12,11 @@ module Stack.Exec where -import Control.Monad.Reader +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl) import Stack.Types.Config import System.Process.Log -import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) @@ -55,7 +53,7 @@ plainEnvSettings = EnvSettings -- sub-process. This allows signals to be propagated (#527) -- -- 2) On windows, an 'ExitCode' exception will be thrown. -exec :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +exec :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m b #ifdef WINDOWS exec = execSpawn @@ -70,7 +68,7 @@ exec menv cmd0 args = do -- is a sub-process, which is helpful in some cases (#1306) -- -- This function only exits by throwing 'ExitCode'. -execSpawn :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +execSpawn :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m b execSpawn menv cmd0 args = do e <- $withProcessTimeLog cmd0 args $ @@ -79,7 +77,7 @@ execSpawn menv cmd0 args = do Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec Right () -> exitSuccess -execObserve :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +execObserve :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> String -> [String] -> m String execObserve menv cmd0 args = do e <- $withProcessTimeLog cmd0 args $ diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 7db9c15daa..0eb0f1e73d 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-} @@ -15,6 +17,7 @@ module Stack.Fetch ( unpackPackages + , unpackPackageIdent , unpackPackageIdents , fetchPackages , untar @@ -31,16 +34,11 @@ import qualified Codec.Archive.Tar.Entry as Tar import Codec.Compression.GZip (decompress) import Control.Applicative import Control.Concurrent.Async (Concurrently (..)) -import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar) import Control.Concurrent.STM -import Control.Exception (assert) -import Control.Monad (join, liftM, unless, void, when) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad (join, liftM, unless, when) +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Reader (ask, runReaderT) -import Control.Monad.Trans.Control -import Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase) +import Control.Monad.Reader (MonadReader, ask, runReaderT) import Crypto.Hash (SHA256 (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -48,7 +46,10 @@ import qualified Data.ByteString.Lazy as L import Data.Either (partitionEithers) import qualified Data.Foldable as F import Data.Function (fix) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -75,7 +76,6 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName import Stack.Types.Version -import System.FilePath ((<.>)) import qualified System.FilePath as FP import System.IO import System.PosixCompat (setFileMode) @@ -88,7 +88,7 @@ data FetchException | UnpackDirectoryAlreadyExists (Set FilePath) | CouldNotParsePackageSelectors [String] | UnknownPackageNames (Set PackageName) - | UnknownPackageIdentifiers (Set PackageIdentifier) String + | UnknownPackageIdentifiers (HashSet PackageIdentifierRevision) String deriving Typeable instance Exception FetchException @@ -116,7 +116,7 @@ instance Show FetchException where intercalate ", " (map packageNameString $ Set.toList names) show (UnknownPackageIdentifiers idents suggestions) = "The following package identifiers were not found in your indices: " ++ - intercalate ", " (map packageIdentifierString $ Set.toList idents) ++ + intercalate ", " (map packageIdentifierRevisionString $ HashSet.toList idents) ++ (if null suggestions then "" else "\n" ++ suggestions) -- | Fetch packages into the cache without unpacking @@ -131,23 +131,21 @@ fetchPackages idents' = do assert (Map.null nowUnpacked) (return ()) where -- Since we're just fetching tarballs and not unpacking cabal files, we can - -- always provide a Nothing Git SHA - idents = Map.fromList $ map (, Nothing) $ Set.toList idents' + -- always provide a Nothing cabal file info + idents = map (flip PackageIdentifierRevision Nothing) $ Set.toList idents' -- | Intended to work for the command line command. unpackPackages :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers -> m () -unpackPackages mMiniBuildPlan dest input = do +unpackPackages mSnapshotDef dest input = do dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages mMiniBuildPlan - (Map.fromList $ map (, Nothing) idents) - (Set.fromList names) + resolved <- resolvePackages mSnapshotDef idents (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved unless (Map.null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked @@ -161,12 +159,31 @@ unpackPackages mMiniBuildPlan dest input = do where -- Possible future enhancement: parse names as name + version range parse s = - case parsePackageNameFromString s of + case parsePackageName t of Right x -> Right $ Left x Left _ -> - case parsePackageIdentifierFromString s of - Left _ -> Left s + case parsePackageIdentifierRevision t of Right x -> Right $ Right x + Left _ -> Left s + where + t = T.pack s + +-- | Same as 'unpackPackageIdents', but for a single package. +unpackPackageIdent + :: (StackMiniM env m, HasConfig env) + => Path Abs Dir -- ^ unpack directory + -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 + -> PackageIdentifierRevision + -> m (Path Abs Dir) +unpackPackageIdent unpackDir distDir (PackageIdentifierRevision ident mcfi) = do + -- FIXME make this more direct in the future + m <- unpackPackageIdents unpackDir (Just distDir) [PackageIdentifierRevision ident mcfi] + case Map.toList m of + [(ident', dir)] + | ident /= ident' -> error "unpackPackageIdent: ident mismatch" + | otherwise -> return dir + [] -> error "unpackPackageIdent: empty list" + _ -> error "unpackPackageIdent: multiple results" -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. @@ -174,7 +191,7 @@ unpackPackageIdents :: (StackMiniM env m, HasConfig env) => Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 - -> Map PackageIdentifier (Maybe GitSHA1) + -> [PackageIdentifierRevision] -> m (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents unpackDir mdistDir idents = do resolved <- resolvePackages Nothing idents Set.empty @@ -191,11 +208,11 @@ data ResolvedPackage = ResolvedPackage -- | Resolve a set of package names and identifiers into @FetchPackage@ values. resolvePackages :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan - -> Map PackageIdentifier (Maybe GitSHA1) + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> [PackageIdentifierRevision] -> Set PackageName -> m [ResolvedPackage] -resolvePackages mMiniBuildPlan idents0 names0 = do +resolvePackages mSnapshotDef idents0 names0 = do eres <- go case eres of Left _ -> do @@ -203,19 +220,19 @@ resolvePackages mMiniBuildPlan idents0 names0 = do go >>= either throwM return Right x -> return x where - go = r <$> resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 + go = r <$> resolvePackagesAllowMissing mSnapshotDef idents0 names0 r (missingNames, missingIdents, idents) | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames - | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" + | not $ HashSet.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" | otherwise = Right idents resolvePackagesAllowMissing :: (StackMiniM env m, HasConfig env) - => Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan - -> Map PackageIdentifier (Maybe GitSHA1) + => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan + -> [PackageIdentifierRevision] -> Set PackageName - -> m (Set PackageName, Set PackageIdentifier, [ResolvedPackage]) -resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do + -> m (Set PackageName, HashSet PackageIdentifierRevision, [ResolvedPackage]) +resolvePackagesAllowMissing mSnapshotDef idents0 names0 = do (res1, res2, resolved) <- inner if any (isJust . snd) resolved then do @@ -224,12 +241,12 @@ resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do (res1', res2', resolved') <- inner -- Print an error message if any SHAs are still missing. - F.forM_ resolved' $ \(rp, missing) -> F.forM_ missing $ \(GitSHA1 sha) -> + F.forM_ resolved' $ \(rp, missing) -> F.forM_ missing $ \cfi -> $logWarn $ mconcat [ "Did not find .cabal file for " , T.pack $ packageIdentifierString $ rpIdent rp - , " with SHA of " - , decodeUtf8 sha + , " with hash of " + , showCabalHash $ cfiHash cfi , " in tarball-based cache" ] @@ -241,58 +258,63 @@ resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = do let versions = Map.fromListWith max $ map toTuple $ Map.keys caches - getNamed :: PackageName -> Maybe (PackageIdentifier, Maybe GitSHA1) + getNamed :: PackageName -> Maybe PackageIdentifierRevision getNamed = - case mMiniBuildPlan of + case mSnapshotDef of Nothing -> getNamedFromIndex - Just mbp -> getNamedFromBuildPlan mbp + Just sd -> getNamedFromSnapshotDef sd + + getNamedFromSnapshotDef sd name = do + loop $ sdLocations sd + where + loop [] = Nothing + loop (PLIndex ident@(PackageIdentifierRevision (PackageIdentifier name' _) _):rest) + | name == name' = Just ident + | otherwise = loop rest + loop (_:rest) = loop rest - 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)) + (\ver -> PackageIdentifierRevision (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) + $ idents0 <> idents1 + return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved) - goIdent caches shaCaches (ident, mgitsha) = + goIdent caches shaCaches identRev@(PackageIdentifierRevision ident mcfi) = case Map.lookup ident caches of - Nothing -> Left ident + Nothing -> Left identRev Just (index, cache) -> - let (index', cache', missingGitSHA) = - case mgitsha of - Nothing -> (index, cache, mgitsha) - Just gitsha -> - case HashMap.lookup gitsha shaCaches of + let (index', cache', missingCFI) = + case mcfi of + Nothing -> (index, cache, mcfi) + Just cfi -> + case HashMap.lookup (cfiHash cfi) shaCaches of -- TODO check size? Just (index'', offsetSize) -> ( index'' , cache { pcOffsetSize = offsetSize } -- we already got the info - -- about this SHA, don't do + -- about this cabal file, don't do -- any lookups later , Nothing ) - -- Index using HTTP, so we're missing the Git SHA - Nothing -> (index, cache, mgitsha) + -- Index using HTTP, so we're missing the cabal file + Nothing -> (index, cache, mcfi) in Right (ResolvedPackage { rpIdent = ident , rpCache = cache' , rpIndex = index' - }, missingGitSHA) + }, missingCFI) data ToFetch = ToFetch { tfTarball :: !(Path Abs File) , tfDestDir :: !(Maybe (Path Abs Dir)) , tfUrl :: !T.Text , tfSize :: !(Maybe Word64) - , tfSHA256 :: !(Maybe ByteString) + , tfSHA256 :: !(Maybe StaticSHA256) , tfCabal :: !ByteString -- ^ Contents of the .cabal file } @@ -304,7 +326,7 @@ data ToFetchResult = ToFetchResult -- | Add the cabal files to a list of idents with their caches. withCabalFiles - :: (StackMiniM env m, HasConfig env) + :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) => IndexName -> [(ResolvedPackage, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) @@ -326,12 +348,10 @@ withCabalFiles name pkgs f = do -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader - :: (StackMiniM env m, HasConfig env, MonadBaseUnlift IO m) - => ((PackageIdentifier -> IO ByteString) -> m a) + :: (StackMiniM env m, HasConfig env) + => ((PackageIdentifierRevision -> IO ByteString) -> m a) -> m a withCabalLoader inner = do - env <- ask - -- Want to try updating the index once during a single run for missing -- package identifiers. We also want to ensure we only update once at a -- time @@ -339,16 +359,16 @@ withCabalLoader inner = do -- TODO: probably makes sense to move this concern into getPackageCaches updateRef <- liftIO $ newMVar True - loadCaches <- getPackageCachesIO - runInBase <- liftBaseWith $ \run -> return (void . run) - unlift <- askRunBase + u <- askUnliftIO + + env <- ask -- TODO in the future, keep all of the necessary @Handle@s open - let doLookup :: PackageIdentifier + let doLookup :: PackageIdentifierRevision -> IO ByteString doLookup ident = do - (caches, _gitSHACaches) <- loadCaches - eres <- unlift $ lookupPackageIdentifierExact ident env caches + (caches, cachesRev) <- unliftIO u getPackageCaches + eres <- runReaderT (lookupPackageIdentifierExact ident caches cachesRev) env case eres of Just bs -> return bs -- Update the cache and try again @@ -365,10 +385,10 @@ withCabalLoader inner = do <> "." join $ modifyMVar updateRef $ \toUpdate -> if toUpdate then do - runInBase $ do + unliftIO u $ do $logInfo $ T.concat [ "Didn't see " - , T.pack $ packageIdentifierString ident + , T.pack $ packageIdentifierRevisionString ident , " in your package indices.\n" , "Updating and trying again." ] @@ -378,21 +398,26 @@ withCabalLoader inner = do return (False, doLookup ident) else return (toUpdate, throwM $ UnknownPackageIdentifiers - (Set.singleton ident) (T.unpack suggestions)) + (HashSet.singleton ident) (T.unpack suggestions)) inner doLookup lookupPackageIdentifierExact - :: (StackMiniM env m, HasConfig env) - => PackageIdentifier - -> env + :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + => PackageIdentifierRevision -> PackageCaches + -> HashMap CabalHash (PackageIndex, OffsetSize) -> m (Maybe ByteString) -lookupPackageIdentifierExact ident env caches = - case Map.lookup ident caches of +lookupPackageIdentifierExact (PackageIdentifierRevision ident mcfi) caches cachesRev = do + let mpair = + case mcfi of + Nothing -> Map.lookup ident caches + Just cfi -> fmap + (\(index, size) -> (index, PackageCache size Nothing)) + (HashMap.lookup (cfiHash cfi) cachesRev) + case mpair of Nothing -> return Nothing Just (index, cache) -> do - [bs] <- flip runReaderT env - $ withCabalFiles (indexName index) + [bs] <- withCabalFiles (indexName index) [(ResolvedPackage { rpIdent = ident , rpCache = cache @@ -405,10 +430,10 @@ lookupPackageIdentifierExact ident env caches = -- with the same name and the same two first version number components found -- in the caches. fuzzyLookupCandidates - :: PackageIdentifier + :: PackageIdentifierRevision -> PackageCaches -> Maybe (NonEmpty PackageIdentifier) -fuzzyLookupCandidates (PackageIdentifier name ver) caches = +fuzzyLookupCandidates (PackageIdentifierRevision (PackageIdentifier name ver) _rev) caches = let (_, zero, bigger) = Map.splitLookup zeroIdent caches zeroIdent = PackageIdentifier name $(mkVersion "0.0") sameName (PackageIdentifier n _) = n == name @@ -420,10 +445,10 @@ fuzzyLookupCandidates (PackageIdentifier name ver) caches = -- package caches. This should be called before giving up, i.e. when -- 'fuzzyLookupCandidates' cannot return anything. typoCorrectionCandidates - :: PackageIdentifier + :: PackageIdentifierRevision -> PackageCaches -> Maybe (NonEmpty T.Text) -typoCorrectionCandidates ident = +typoCorrectionCandidates (PackageIdentifierRevision ident _mcfi) = let getName = packageNameText . packageIdentifierName name = getName ident in NE.nonEmpty @@ -501,7 +526,7 @@ fetchPackages' mdistDir toFetchAll = do connCount <- view $ configL.to configConnectionCount outputVar <- liftIO $ newTVarIO Map.empty - runInBase <- liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO parMapM_ connCount (go outputVar runInBase) @@ -521,7 +546,7 @@ fetchPackages' mdistDir toFetchAll = do let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs) let downloadReq = DownloadRequest { drRequest = req - , drHashChecks = map toHashCheck $ maybeToList (tfSHA256 toFetch) + , drHashChecks = map (toHashCheck . staticSHA256ToBase16) $ maybeToList (tfSHA256 toFetch) , drLengthCheck = fromIntegral <$> tfSize toFetch , drRetryPolicy = drRetryPolicyDefault } @@ -557,7 +582,7 @@ fetchPackages' mdistDir toFetchAll = do let cabalFP = innerDest FP. packageNameString (packageIdentifierName ident) - <.> "cabal" + FP.<.> "cabal" S.writeFile cabalFP $ tfCabal toFetch atomically $ modifyTVar outputVar $ Map.insert ident destDir @@ -627,7 +652,7 @@ untar tarPath expectedTarFolder destDirParent = do perm) filePerms return unexpectedEntries -parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m) +parMapM_ :: (F.Foldable f,MonadUnliftIO m) => Int -> (a -> m ()) -> f a @@ -636,8 +661,7 @@ parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs parMapM_ cnt f xs0 = do var <- liftIO (newTVarIO $ F.toList xs0) - -- See comment on similar line in Stack.Build - runInBase <- liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO let worker = fix $ \loop -> join $ atomically $ do xs <- readTVar var diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs index f0c7dc9932..a5fdbdc07e 100644 --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -10,9 +10,8 @@ import Blaze.ByteString.Builder (toLazyByteString, copyByteString) import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Concurrent.Async (race_) import Control.Concurrent.STM -import Control.Exception (Exception, fromException, catch, throwIO) -import Control.Exception.Safe (tryAny) import Control.Monad (forever, unless, when) +import Control.Monad.IO.Unlift import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs index 9d2afb455a..37c7ea42bd 100644 --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -1,4 +1,4 @@ --- FIXME See how much of this module can be deleted. +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,8 +11,6 @@ module Stack.GhcPkg (getGlobalDB - ,EnvOverride - ,envHelper ,findGhcPkgField ,createDatabase ,unregisterGhcPkgId @@ -22,10 +20,8 @@ module Stack.GhcPkg where import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.List @@ -49,15 +45,15 @@ import System.FilePath (searchPathSeparator) import System.Process.Read -- | Get the global package database -getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +getGlobalDB :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> m (Path Abs Dir) getGlobalDB menv wc = do $logDebug "Getting global package database location" -- This seems like a strange way to get the global package database -- location, but I don't know of a better one - bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return + bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwIO return let fp = S8.unpack $ stripTrailingColon $ firstLine bs - resolveDir' fp + liftIO $ resolveDir' fp where stripTrailingColon bs | S8.null bs = bs @@ -66,7 +62,7 @@ getGlobalDB menv wc = do firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable -ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +ghcPkg :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] @@ -84,7 +80,7 @@ ghcPkg menv wc pkgDbs args = do args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. -createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +createDatabase :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () createDatabase menv wc db = do exists <- doesFileExist (db $(mkRelFile "package.cache")) @@ -112,7 +108,7 @@ createDatabase menv wc db = do case eres of Left e -> do $logError $ T.pack $ "Unable to create package database at " ++ toFilePath db - throwM e + throwIO e Right _ -> return () -- | Get the name to use for "ghc-pkg", given the compiler version. @@ -128,7 +124,7 @@ packageDbFlags pkgDbs = -- | Get the value of a field of the package. findGhcPkgField - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases @@ -149,7 +145,7 @@ findGhcPkgField menv wc pkgDbs name field = do fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs -- | Get the version of the package -findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +findGhcPkgVersion :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases @@ -161,10 +157,10 @@ findGhcPkgVersion menv wc pkgDbs name = do Just !v -> return (parseVersion v) _ -> return Nothing -unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) +unregisterGhcPkgId :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler - -> CompilerVersion + -> CompilerVersion 'CVActual -> Path Abs Dir -- ^ package database -> GhcPkgId -> PackageIdentifier @@ -183,7 +179,7 @@ unregisterGhcPkgId menv wc cv pkgDb gid ident = do _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. -getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +getCabalPkgVer :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> m Version getCabalPkgVer menv wc = do $logDebug "Getting Cabal package version" @@ -192,7 +188,7 @@ getCabalPkgVer menv wc = do wc [] -- global DB cabalPackageName - maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return mres + maybe (throwIO $ Couldn'tFindPkgId cabalPackageName) return mres -- | Get the value for GHC_PACKAGE_PATH mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index ca5ca70b27..7074173179 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -22,13 +22,10 @@ module Stack.Ghci import Control.Applicative import Control.Arrow (second) -import Control.Exception.Safe (tryAny) import Control.Monad hiding (forM) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.State.Strict (State, execState, get, modify) -import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.Function @@ -132,7 +129,7 @@ instance Show GhciException where -- | Launch a GHCi session for the given local package targets with the -- given options and configure it with the load paths and extensions -- of those targets. -ghci :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> m () +ghci :: (StackM r m, HasEnvConfig r) => GhciOpts -> m () ghci opts@GhciOpts{..} = do let buildOptsCLI = defaultBuildOptsCLI { boptsCLITargets = [] @@ -153,11 +150,9 @@ ghci opts@GhciOpts{..} = do (targetMap, fileInfo, extraFiles) <- findFileTargets locals rawFileTargets return (targetMap, Just (fileInfo, extraFiles)) Right rawTargets -> do - (_,_,normalTargets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI + (_,_,normalTargets) <- parseTargets AllowNoTargets buildOptsCLI { boptsCLITargets = rawTargets } return (normalTargets, Nothing) - -- Make sure the targets are known. - checkTargets inputTargets -- Get a list of all the local target packages. localTargets <- getAllLocalTargets opts inputTargets mainIsTargets sourceMap -- Check if additional package arguments are sensible. @@ -177,7 +172,7 @@ preprocessTargets rawTargets = do rawTargets fileTargets <- forM fileTargetsRaw $ \fp0 -> do let fp = T.unpack fp0 - mpath <- forgivingAbsence (resolveFile' fp) + mpath <- liftIO $ forgivingAbsence (resolveFile' fp) case mpath of Nothing -> throwM (MissingFileTarget fp) Just path -> return path @@ -186,9 +181,9 @@ preprocessTargets rawTargets = do (False, _) -> return (Left fileTargets) _ -> return (Right normalTargets) -parseMainIsTargets :: (StackM r m, HasEnvConfig r) => BuildOptsCLI -> Maybe Text -> m (Maybe (Map PackageName SimpleTarget)) +parseMainIsTargets :: (StackM r m, HasEnvConfig r) => BuildOptsCLI -> Maybe Text -> m (Maybe (Map PackageName Target)) parseMainIsTargets buildOptsCLI mtarget = forM mtarget $ \target -> do - (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets buildOptsCLI + (_,_,targets) <- parseTargets AllowNoTargets buildOptsCLI { boptsCLITargets = [target] } return targets @@ -196,7 +191,7 @@ findFileTargets :: (StackM r m, HasEnvConfig r) => [LocalPackage] -> [Path Abs File] - -> m (Map PackageName SimpleTarget, Map PackageName (Set (Path Abs File)), [Path Abs File]) + -> m (Map PackageName Target, Map PackageName (Set (Path Abs File)), [Path Abs File]) findFileTargets locals fileTargets = do filePackages <- forM locals $ \lp -> do (_,compFiles,_,_) <- getPackageFiles (packageFiles (lpPackage lp)) (lpCabalFile lp) @@ -230,8 +225,8 @@ findFileTargets locals fileTargets = do return $ Right (fp, x) let (extraFiles, associatedFiles) = partitionEithers results targetMap = - foldl unionSimpleTargets M.empty $ - map (\(_, (name, comp)) -> M.singleton name (STLocalComps (S.singleton comp))) + foldl unionTargets M.empty $ + map (\(_, (name, comp)) -> M.singleton name (TargetComps (S.singleton comp))) associatedFiles infoMap = foldl (M.unionWith S.union) M.empty $ @@ -239,43 +234,28 @@ findFileTargets locals fileTargets = do associatedFiles return (targetMap, infoMap, extraFiles) -checkTargets - :: (StackM r m, HasEnvConfig r) - => Map PackageName SimpleTarget - -> m () -checkTargets mp = do - let filtered = M.filter (== STUnknown) mp - unless (M.null filtered) $ do - bconfig <- view buildConfigL - throwM $ UnknownTargets (M.keysSet filtered) M.empty (bcStackYaml bconfig) - getAllLocalTargets :: (StackM r m, HasEnvConfig r) => GhciOpts - -> Map PackageName SimpleTarget - -> Maybe (Map PackageName SimpleTarget) + -> Map PackageName Target + -> Maybe (Map PackageName Target) -> SourceMap - -> m [(PackageName, (Path Abs File, SimpleTarget))] + -> m [(PackageName, (Path Abs File, Target))] getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do -- Use the 'mainIsTargets' as normal targets, for CLI concision. See -- #1845. This is a little subtle - we need to do the target parsing -- independently in order to handle the case where no targets are -- specified. - let targets = maybe targets0 (unionSimpleTargets targets0) mainIsTargets - packages <- getLocalPackages + let targets = maybe targets0 (unionTargets targets0) mainIsTargets + packages <- lpProject <$> getLocalPackages -- Find all of the packages that are directly demanded by the -- targets. directlyWanted <- forMaybeM (M.toList packages) $ - \(dir,treatLikeExtraDep) -> - do cabalfp <- findOrGenerateCabalFile dir - name <- parsePackageNameFromFilePath cabalfp - if treatLikeExtraDep - then return Nothing - else case M.lookup name targets of - Just simpleTargets -> - return (Just (name, (cabalfp, simpleTargets))) - Nothing -> return Nothing + \(name, lpv) -> + case M.lookup name targets of + Just simpleTargets -> return (Just (name, (lpvCabalFP lpv, simpleTargets))) + Nothing -> return Nothing -- Figure out let extraLoadDeps = getExtraLoadDeps ghciLoadLocalDeps sourceMap directlyWanted if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps @@ -296,7 +276,7 @@ getAllLocalTargets GhciOpts{..} targets0 mainIsTargets sourceMap = do ] return (directlyWanted ++ extraLoadDeps) -buildDepsAndInitialSteps :: (StackM r m, HasEnvConfig r, MonadBaseUnlift IO m) => GhciOpts -> [Text] -> m () +buildDepsAndInitialSteps :: (StackM r m, HasEnvConfig r) => GhciOpts -> [Text] -> m () buildDepsAndInitialSteps GhciOpts{..} targets0 = do let targets = targets0 ++ map T.pack ghciAdditionalPackages -- If necessary, do the build, for local packagee targets, only do @@ -323,8 +303,8 @@ checkAdditionalPackages pkgs = forM pkgs $ \name -> do runGhci :: (StackM r m, HasEnvConfig r) => GhciOpts - -> [(PackageName, (Path Abs File, SimpleTarget))] - -> Maybe (Map PackageName SimpleTarget) + -> [(PackageName, (Path Abs File, Target))] + -> Maybe (Map PackageName Target) -> [GhciPkgInfo] -> [Path Abs File] -> m () @@ -372,7 +352,7 @@ runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles = do if "Intero" `isPrefixOf` output then return renderScriptIntero else return renderScriptGhci - withSystemTempDir "ghci" $ \tmpDirectory -> do + withRunIO $ \run -> withSystemTempDir "ghci" $ \tmpDirectory -> run $ do macrosOptions <- writeMacrosFile tmpDirectory pkgs if ghciNoLoadModules then execGhci macrosOptions @@ -444,8 +424,8 @@ getFileTargets = concatMap (concatMap S.toList . maybeToList . ghciPkgTargetFile figureOutMainFile :: (StackM r m) => BuildOpts - -> Maybe (Map PackageName SimpleTarget) - -> [(PackageName, (Path Abs File, SimpleTarget))] + -> Maybe (Map PackageName Target) + -> [(PackageName, (Path Abs File, Target))] -> [GhciPkgInfo] -> m (Maybe (Path Abs File)) figureOutMainFile bopts mainIsTargets targets0 packages = do @@ -532,7 +512,7 @@ getGhciPkgInfos -> SourceMap -> [PackageName] -> Maybe (Map PackageName (Set (Path Abs File))) - -> [(PackageName, (Path Abs File, SimpleTarget))] + -> [(PackageName, (Path Abs File, Target))] -> m [GhciPkgInfo] getGhciPkgInfos buildOptsCLI sourceMap addPkgs mfileTargets localTargets = do menv <- getMinimalEnvOverride @@ -559,7 +539,7 @@ makeGhciPkgInfo -> Maybe (Map PackageName (Set (Path Abs File))) -> PackageName -> Path Abs File - -> SimpleTarget + -> Target -> m GhciPkgInfo makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets name cabalfp target = do bopts <- view buildOptsL @@ -612,9 +592,9 @@ makeGhciPkgInfo buildOptsCLI sourceMap installedMap locals addPkgs mfileTargets -- NOTE: this should make the same choices as the components code in -- 'loadLocalPackage'. Unfortunately for now we reiterate this logic -- (differently). -wantedPackageComponents :: BuildOpts -> SimpleTarget -> Package -> Set NamedComponent -wantedPackageComponents _ (STLocalComps cs) _ = cs -wantedPackageComponents bopts STLocalAll pkg = S.fromList $ +wantedPackageComponents :: BuildOpts -> Target -> Package -> Set NamedComponent +wantedPackageComponents _ (TargetComps cs) _ = cs +wantedPackageComponents bopts (TargetAll ProjectPackage) pkg = S.fromList $ (if packageHasLibrary pkg then [CLib] else []) ++ map CExe (S.toList (packageExes pkg)) <> (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <> @@ -718,8 +698,8 @@ checkForDuplicateModules pkgs = do getExtraLoadDeps :: Bool -> SourceMap - -> [(PackageName, (Path Abs File, SimpleTarget))] - -> [(PackageName, (Path Abs File, SimpleTarget))] + -> [(PackageName, (Path Abs File, Target))] + -> [(PackageName, (Path Abs File, Target))] getExtraLoadDeps loadAllDeps sourceMap targets = M.toList $ (\mp -> foldl' (flip M.delete) mp (map fst targets)) $ @@ -732,7 +712,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = case M.lookup name sourceMap of Just (PSLocal lp) -> M.keys (packageDeps (lpPackage lp)) _ -> [] - go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, SimpleTarget))) Bool + go :: PackageName -> State (Map PackageName (Maybe (Path Abs File, Target))) Bool go name = do cache <- get case (M.lookup name cache, M.lookup name sourceMap) of @@ -743,7 +723,7 @@ getExtraLoadDeps loadAllDeps sourceMap targets = shouldLoad <- liftM or $ mapM go deps if shouldLoad then do - modify (M.insert name (Just (lpCabalFile lp, STLocalComps (S.singleton CLib)))) + modify (M.insert name (Just (lpCabalFile lp, TargetComps (S.singleton CLib)))) return True else do modify (M.insert name Nothing) @@ -773,21 +753,20 @@ setScriptPerms fp = do ] #endif -unionSimpleTargets :: Ord k => Map k SimpleTarget -> Map k SimpleTarget -> Map k SimpleTarget -unionSimpleTargets = M.unionWith $ \l r -> +unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target +unionTargets = M.unionWith $ \l r -> case (l, r) of - (STUnknown, _) -> r - (STNonLocal, _) -> r - (STLocalComps sl, STLocalComps sr) -> STLocalComps (S.union sl sr) - (STLocalComps _, STLocalAll) -> STLocalAll - (STLocalComps _, _) -> l - (STLocalAll, _) -> STLocalAll - -hasLocalComp :: (NamedComponent -> Bool) -> SimpleTarget -> Bool + (TargetAll Dependency, _) -> r + (TargetComps sl, TargetComps sr) -> TargetComps (S.union sl sr) + (TargetComps _, TargetAll ProjectPackage) -> TargetAll ProjectPackage + (TargetComps _, _) -> l + (TargetAll ProjectPackage, _) -> TargetAll ProjectPackage + +hasLocalComp :: (NamedComponent -> Bool) -> Target -> Bool hasLocalComp p t = case t of - STLocalComps s -> any p (S.toList s) - STLocalAll -> True + TargetComps s -> any p (S.toList s) + TargetAll ProjectPackage -> True _ -> False diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 435c38de0f..dc065826a7 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -7,8 +7,7 @@ module Stack.Hoogle ( hoogleCmd ) where -import Control.Exception -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.ByteString.Char8 as S8 import Data.List (find) diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs index 9457791b81..66846b1825 100644 --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -15,8 +15,6 @@ import Control.Monad.Reader import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T -import Stack.Build.Source (getLocalPackageViews) -import Stack.Build.Target (LocalPackageView(..)) import Stack.Config (getLocalPackages) import Stack.Package (findOrGenerateCabalFile) import Stack.Types.Config @@ -30,7 +28,7 @@ listPackages = do -- TODO: Instead of setting up an entire EnvConfig only to look up the package directories, -- make do with a Config (and the Project inside) and use resolvePackageEntry to get -- the directory. - packageDirs <- liftM Map.keys getLocalPackages + packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do cabalfp <- findOrGenerateCabalFile dir pkgName <- parsePackageNameFromFilePath cabalfp @@ -39,7 +37,7 @@ listPackages = do -- | List the targets in the current project. listTargets :: (StackM env m, HasEnvConfig env) => m () listTargets = - do rawLocals <- getLocalPackageViews + do rawLocals <- lpProject <$> getLocalPackages $logInfo (T.intercalate "\n" @@ -47,7 +45,7 @@ listTargets = renderPkgComponent (concatMap toNameAndComponent - (Map.toList (Map.map fst rawLocals))))) + (Map.toList rawLocals)))) where toNameAndComponent (pkgName,view') = map (pkgName, ) (Set.toList (lpvComponents view')) diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs index 65c7d0d0e2..1f59c9d0f4 100644 --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -11,10 +11,8 @@ module Stack.Image imgCmdName, imgDockerCmdName, imgOptsFromMonoid) where -import Control.Exception.Lifted hiding (finally) import Control.Monad -import Control.Monad.Catch hiding (bracket) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.Char (toLower) import qualified Data.Map.Strict as Map @@ -48,7 +46,7 @@ stageContainerImageArtifacts mProjectRoot imageNames = do (\(idx,opts) -> do imageDir <- imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx - ignoringAbsence (removeDirRecur imageDir) + liftIO (ignoringAbsence (removeDirRecur imageDir)) ensureDir imageDir stageExesInDir opts imageDir syncAddContentToDir opts imageDir) @@ -94,10 +92,10 @@ stageExesInDir opts dir = do Nothing -> do $logInfo "" $logInfo "Note: 'executables' not specified for a image container, so every executable in the project's local bin dir will be used." - mcontents <- forgivingAbsence $ listDir srcBinPath + mcontents <- liftIO $ forgivingAbsence $ listDir srcBinPath case mcontents of Just (files, dirs) - | not (null files) || not (null dirs) -> copyDirRecur srcBinPath destBinPath + | not (null files) || not (null dirs) -> liftIO $ copyDirRecur srcBinPath destBinPath _ -> $prettyWarn "The project's local bin dir contains no files, so no executables will be added to the docker image." $logInfo "" @@ -123,7 +121,7 @@ syncAddContentToDir opts dir = do do sourcePath <- resolveDir root source let destFullPath = dir dropRoot destPath ensureDir destFullPath - copyDirRecur sourcePath destFullPath) + liftIO $ copyDirRecur sourcePath destFullPath) -- | Derive an image name from the project directory. imageName @@ -192,7 +190,7 @@ extendDockerImageWithEntrypoint dockerConfig dir = do -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = - fromMaybe (throw StackImageCannotDetermineProjectRootException) + fromMaybe (impureThrow StackImageCannotDetermineProjectRootException) -- | The command name for dealing with images. imgCmdName diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index a9834e16b0..d3e28ef272 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -8,11 +8,9 @@ module Stack.Init , InitOpts (..) ) where -import Control.Exception (assert) -import Control.Exception.Safe (catchAny) +import Control.Applicative import Control.Monad -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Char8 as BC @@ -42,11 +40,13 @@ import Stack.BuildPlan import Stack.Config (getSnapshots, makeConcreteResolver) import Stack.Constants +import Stack.Snapshot (loadResolver) import Stack.Solver import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Resolver import Stack.Types.StackT (StackM) @@ -83,8 +83,13 @@ initProject whichCmd currDir initOpts mresolver = do cabalfps <- liftM concat $ mapM find dirs' (bundle, dupPkgs) <- cabalPackagesCheck cabalfps noPkgMsg Nothing - (r, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts - mresolver bundle + (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts + mresolver bundle + + -- Kind of inefficient, since we've already parsed this value. But + -- better to reparse in this one case than carry the unneeded data + -- around everywhere in the codebase. + resolver <- parseCustomLocation (Just (parent dest)) (void (sdResolver sd)) let ignored = Map.difference bundle rbundle dupPkgMsg @@ -120,9 +125,11 @@ initProject whichCmd currDir initOpts mresolver = do p = Project { projectUserMsg = if userMsg == "" then Nothing else Just userMsg , projectPackages = pkgs - , projectExtraDeps = extraDeps - , projectFlags = PackageFlags (removeSrcPkgDefaultFlags gpds flags) - , projectResolver = r + , projectDependencies = map + (\(n, v) -> PLIndex $ PackageIdentifierRevision (PackageIdentifier n v) Nothing) + (Map.toList extraDeps) + , projectFlags = removeSrcPkgDefaultFlags gpds flags + , projectResolver = resolver , projectCompiler = Nothing , projectExtraPackageDBs = [] } @@ -137,14 +144,10 @@ initProject whichCmd currDir initOpts mresolver = do makeRel = fmap toFilePath . makeRelativeToCurrentDir pkgs = map toPkg $ Map.elems (fmap (parent . fst) rbundle) - toPkg dir = PackageEntry - { peExtraDepMaybe = Nothing - , peLocation = PLFilePath $ makeRelDir dir - , peSubdirs = [] - } + toPkg dir = PLFilePath $ makeRelDir dir indent t = T.unlines $ fmap (" " <>) (T.lines t) - $logInfo $ "Initialising configuration using resolver: " <> resolverName r + $logInfo $ "Initialising configuration using resolver: " <> sdResolverName sd $logInfo $ "Total number of user packages considered: " <> T.pack (show (Map.size bundle + length dupPkgs)) @@ -192,14 +195,24 @@ renderStackYaml p ignoredPackages dupPackages = <> B.byteString footerHelp goComment o (name, comment) = - case HM.lookup name o of + case (convert <$> HM.lookup name o) <|> nonPresentValue name of Nothing -> assert (name == "user-message") mempty Just v -> B.byteString comment <> B.byteString "\n" <> - B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <> + v <> if name == "packages" then commentedPackages else "" <> B.byteString "\n" + where + convert v = B.byteString (Yaml.encode $ Yaml.object [(name, v)]) + + -- Some fields in stack.yaml are optional and may not be + -- generated. For these, we provided commented out dummy + -- values to go along with the comments. + nonPresentValue "extra-deps" = Just "# extra-deps: []\n" + nonPresentValue "flags" = Just "# flags: {}\n" + nonPresentValue "extra-package-dbs" = Just "# extra-package-dbs: []\n" + nonPresentValue _ = Nothing commentLine l | null l = "#" | otherwise = "# " ++ l @@ -245,7 +258,7 @@ renderStackYaml p ignoredPackages dupPackages = , "" , "Some commonly used options have been documented as comments in this file." , "For advanced use and comprehensive documentation of the format, please see:" - , "http://docs.haskellstack.org/en/stable/yaml_configuration/" + , "https://docs.haskellstack.org/en/stable/yaml_configuration/" ] resolverHelp = commentHelp @@ -339,7 +352,7 @@ getDefaultResolver -> Maybe AbstractResolver -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> m ( Resolver + -> m ( SnapshotDef , Map PackageName (Map FlagName Bool) , Map PackageName Version , Map PackageName (Path Abs File, C.GenericPackageDescription)) @@ -347,19 +360,21 @@ getDefaultResolver -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = - maybe selectSnapResolver makeConcreteResolver mresolver - >>= getWorkingResolverPlan whichCmd stackYaml initOpts bundle +getDefaultResolver whichCmd stackYaml initOpts mresolver bundle = do + sd <- maybe selectSnapResolver (makeConcreteResolver (Just root) >=> loadResolver) mresolver + getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd where + root = parent stackYaml -- TODO support selecting best across regular and custom snapshots selectSnapResolver = do let gpds = Map.elems (fmap snd bundle) snaps <- fmap getRecommendedSnapshots getSnapshots' - (s, r) <- selectBestSnapshot gpds snaps + sds <- mapM (loadResolver . ResolverSnapshot) snaps + (s, r) <- selectBestSnapshot (parent stackYaml) gpds sds case r of BuildPlanCheckFail {} | not (omitPackages initOpts) -> throwM (NoMatchingSnapshot whichCmd snaps) - _ -> return $ ResolverSnapshot s + _ -> return s getWorkingResolverPlan :: (StackM env m, HasConfig env, HasGHCVariant env) @@ -368,30 +383,30 @@ getWorkingResolverPlan -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> Resolver - -> m ( Resolver + -> SnapshotDef + -> m ( SnapshotDef , Map PackageName (Map FlagName Bool) , Map PackageName Version , Map PackageName (Path Abs File, C.GenericPackageDescription)) - -- ^ ( Resolver + -- ^ ( SnapshotDef -- , Flags for src packages and extra deps -- , Extra dependencies -- , Src packages actually considered) -getWorkingResolverPlan whichCmd stackYaml initOpts bundle resolver = do - $logInfo $ "Selected resolver: " <> resolverName resolver +getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do + $logInfo $ "Selected resolver: " <> sdResolverName sd go bundle where go info = do - eres <- checkBundleResolver whichCmd stackYaml initOpts info resolver + eres <- checkBundleResolver whichCmd stackYaml initOpts info sd -- if some packages failed try again using the rest case eres of - Right (f, edeps)-> return (resolver, f, edeps, info) + Right (f, edeps)-> return (sd, f, edeps, info) Left ignored | Map.null available -> do $logWarn "*** Could not find a working plan for any of \ \the user packages.\nProceeding to create a \ \config anyway." - return (resolver, Map.empty, Map.empty, Map.empty) + return (sd, Map.empty, Map.empty, Map.empty) | otherwise -> do when (Map.size available == Map.size info) $ error "Bug: No packages to ignore" @@ -416,11 +431,11 @@ checkBundleResolver -> InitOpts -> Map PackageName (Path Abs File, C.GenericPackageDescription) -- ^ Src package name: cabal dir, cabal package description - -> Resolver + -> SnapshotDef -> m (Either [PackageName] ( Map PackageName (Map FlagName Bool) , Map PackageName Version)) -checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do - result <- checkResolverSpec gpds Nothing resolver +checkBundleResolver whichCmd stackYaml initOpts bundle sd = do + result <- checkSnapBuildPlan (parent stackYaml) gpds Nothing sd case result of BuildPlanCheckOk f -> return $ Right (f, Map.empty) BuildPlanCheckPartial f e @@ -431,18 +446,19 @@ checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do warnPartial result $logWarn "*** Omitting packages with unsatisfied dependencies" return $ Left $ failedUserPkgs e - | otherwise -> throwM $ ResolverPartial whichCmd resolver (show result) + | otherwise -> throwM $ ResolverPartial whichCmd (sdResolverName sd) (show result) BuildPlanCheckFail _ e _ | omitPackages initOpts -> do $logWarn $ "*** Resolver compiler mismatch: " - <> resolverName resolver + <> sdResolverName sd $logWarn $ indent $ T.pack $ show result return $ Left $ failedUserPkgs e - | otherwise -> throwM $ ResolverMismatch whichCmd resolver (show result) + | otherwise -> throwM $ ResolverMismatch whichCmd (sdResolverName sd) (show result) where + resolver = sdResolver sd indent t = T.unlines $ fmap (" " <>) (T.lines t) warnPartial res = do - $logWarn $ "*** Resolver " <> resolverName resolver + $logWarn $ "*** Resolver " <> sdResolverName sd <> " will need external packages: " $logWarn $ indent $ T.pack $ show res @@ -454,7 +470,7 @@ checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do srcConstraints = mergeConstraints (gpdPackages gpds) flags eresult <- solveResolverSpec stackYaml cabalDirs - (resolver, srcConstraints, Map.empty) + (sd, srcConstraints, Map.empty) case eresult of Right (src, ext) -> return $ Right (fmap snd (Map.union src ext), fmap fst ext) @@ -471,7 +487,8 @@ checkBundleResolver whichCmd stackYaml initOpts bundle resolver = do -- set of packages. findOneIndependent packages flags = do platform <- view platformL - (compiler, _) <- getResolverConstraints stackYaml resolver + menv <- getMinimalEnvOverride + (compiler, _) <- getResolverConstraints menv Nothing stackYaml sd let getGpd pkg = snd (fromJust (Map.lookup pkg bundle)) getFlags pkg = fromJust (Map.lookup pkg flags) deps pkg = gpdPackageDeps (getGpd pkg) compiler platform diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 1e0cf6f5e3..0b144e921b 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -19,8 +19,7 @@ module Stack.New where import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Trans.Writer.Strict import Data.Aeson @@ -84,6 +83,8 @@ new :: (StackM env m, HasConfig env) => NewOpts -> Bool -> m (Path Abs Dir) new opts forceOverwrite = do + when (newOptsProjectName opts `elem` wiredInPackages) $ + throwM $ Can'tUseWiredInName (newOptsProjectName opts) pwd <- getCurrentDir absDir <- if bare then return pwd else do relDir <- parseRelDir (packageNameString project) @@ -378,6 +379,7 @@ data NewException | FailedToDownloadTemplateInfo !HttpException | BadTemplateInfo !String | BadTemplateInfoResponse !Int + | Can'tUseWiredInName !PackageName deriving (Typeable) instance Exception NewException @@ -440,3 +442,5 @@ instance Show NewException where "Template info couldn't be parsed: " <> err show (BadTemplateInfoResponse code) = "Unexpected status code while retrieving templates info: " <> show code + show (Can'tUseWiredInName name) = + "The name \"" <> packageNameString name <> "\" is used by GHC wired-in packages, and so shouldn't be used as a package name" diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs index a5c77990d6..cd07efd83f 100644 --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,9 +13,8 @@ module Stack.Nix ) where import Control.Arrow ((***)) -import Control.Exception (Exception,throw) import Control.Monad hiding (mapM) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger (logDebug) import Data.Maybe import Data.Monoid @@ -45,7 +45,7 @@ import System.Process.Read (getEnvOverride) reexecWithOptionalShell :: (StackM env m, HasConfig env) => Maybe (Path Abs Dir) - -> IO CompilerVersion + -> IO (CompilerVersion 'CVWanted) -> IO () -> m () reexecWithOptionalShell mprojectRoot getCompilerVersion inner = @@ -69,7 +69,7 @@ reexecWithOptionalShell mprojectRoot getCompilerVersion inner = runShellAndExit :: (StackM env m, HasConfig env) => Maybe (Path Abs Dir) - -> IO CompilerVersion + -> IO (CompilerVersion 'CVWanted) -> m (String, [String]) -> m () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do @@ -83,7 +83,7 @@ runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do inContainer <- getInContainer let pkgsInConfig = nixPackages (configNix config) ghc = nixCompiler compilerVersion - pkgs = pkgsInConfig ++ [ghc] + pkgs = pkgsInConfig ++ [ghc, "git"] pkgsStr = "[" <> T.intercalate " " pkgs <> "]" pureShell = nixPureShell (configNix config) addGCRoots = nixAddGCRoots (configNix config) @@ -139,7 +139,7 @@ escape str = "'" ++ foldr (\c -> if c == '\'' then -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir -fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRoot) +fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRoot) -- | Command-line argument for "nix" nixCmdName :: String diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs index 5cf618923b..125f03aadd 100644 --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -20,8 +20,7 @@ import qualified Data.Text as T import qualified Distribution.PackageDescription as C import Options.Applicative import Options.Applicative.Builder.Extra -import Stack.Build.Target (LocalPackageView(..)) -import Stack.Build.Source (getLocalPackageViews) +import Stack.Config (getLocalPackages) import Stack.Options.GlobalParser (globalOptsFromMonoid) import Stack.Runners (loadConfigWithOpts) import Stack.Setup @@ -69,27 +68,27 @@ buildConfigCompleter inner = mkCompleter $ \inputRaw -> do targetCompleter :: Completer targetCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages return $ filter (input `isPrefixOf`) $ concatMap allComponentNames (Map.toList lpvs) where - allComponentNames (name, (lpv, _)) = + allComponentNames (name, lpv) = map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv)) flagCompleter :: Completer flagCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages bconfig <- view buildConfigL let wildcardFlags = nubOrd - $ concatMap (\(name, (_, gpd)) -> - map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags gpd)) + $ concatMap (\(name, lpv) -> + map (\fl -> "*:" ++ flagString name fl) (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs normalFlags - = concatMap (\(name, (_, gpd)) -> + = concatMap (\(name, lpv) -> map (\fl -> packageNameString name ++ ":" ++ flagString name fl) - (C.genPackageFlags gpd)) + (C.genPackageFlags (lpvGPD lpv))) $ Map.toList lpvs flagString name fl = case C.flagName fl of @@ -97,7 +96,7 @@ flagCompleter = buildConfigCompleter $ \input -> do flagEnabled name fl = fromMaybe (C.flagDefault fl) $ Map.lookup (fromCabalFlagName (C.flagName fl)) $ - Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig)) + Map.findWithDefault Map.empty name (bcFlags bconfig) return $ filter (input `isPrefixOf`) $ case input of ('*' : ':' : _) -> wildcardFlags @@ -106,9 +105,9 @@ flagCompleter = buildConfigCompleter $ \input -> do projectExeCompleter :: Completer projectExeCompleter = buildConfigCompleter $ \input -> do - lpvs <- getLocalPackageViews + lpvs <- fmap lpProject getLocalPackages return $ filter (input `isPrefixOf`) $ nubOrd $ - concatMap (\(_, (_, gpd)) -> map fst (C.condExecutables gpd)) $ + concatMap (\(_, lpv) -> map fst (C.condExecutables (lpvGPD lpv))) $ Map.toList lpvs diff --git a/src/Stack/Options/ResolverParser.hs b/src/Stack/Options/ResolverParser.hs index 0d5f4fdee7..631c5b1c91 100644 --- a/src/Stack/Options/ResolverParser.hs +++ b/src/Stack/Options/ResolverParser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} module Stack.Options.ResolverParser where import Data.Monoid.Extra @@ -17,7 +18,7 @@ abstractResolverOptsParser hide = help "Override resolver in project file" <> hideMods hide) -compilerOptsParser :: Bool -> Parser CompilerVersion +compilerOptsParser :: Bool -> Parser (CompilerVersion 'CVWanted) compilerOptsParser hide = option readCompilerVersion (long "compiler" <> @@ -25,7 +26,7 @@ compilerOptsParser hide = help "Use the specified compiler" <> hideMods hide) -readCompilerVersion :: ReadM CompilerVersion +readCompilerVersion :: ReadM (CompilerVersion 'CVWanted) readCompilerVersion = do s <- readerAsk case parseCompilerVersion (T.pack s) of diff --git a/src/Stack/Options/SDistParser.hs b/src/Stack/Options/SDistParser.hs new file mode 100644 index 0000000000..38ae1cd5e0 --- /dev/null +++ b/src/Stack/Options/SDistParser.hs @@ -0,0 +1,29 @@ +module Stack.Options.SDistParser where + +import Data.Monoid +import Options.Applicative +import Options.Applicative.Builder.Extra +import Stack.SDist +import Stack.Options.HpcReportParser (pvpBoundsOption) + +-- | Parser for arguments to `stack sdist` and `stack upload` +sdistOptsParser :: Bool -- ^ Whether to sign by default `stack upload` does, `stack sdist` doesn't + -> Parser SDistOpts +sdistOptsParser signDefault = SDistOpts <$> + many (strArgument $ metavar "DIR" <> completer dirCompleter) <*> + optional pvpBoundsOption <*> + ignoreCheckSwitch <*> + (if signDefault + then switch (long "no-signature" <> help "Do not sign & upload signatures") + else switch (long "sign" <> help "Sign & upload signatures")) <*> + strOption + (long "sig-server" <> metavar "URL" <> showDefault <> + value "https://sig.commercialhaskell.org" <> + help "URL") <*> + buildPackageOption + where + ignoreCheckSwitch = + switch (long "ignore-check" + <> help "Do not check package for common mistakes") + buildPackageOption = + boolFlags False "test-tarball" "building of the resulting tarball" idm diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index bf53f9dc9c..6513adabc4 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -37,17 +37,16 @@ module Stack.Package ,autogenDir ,checkCabalFileName ,printCabalFileWarning - ,cabalFilePackageId) + ,cabalFilePackageId + ,rawParseGPD) where import Prelude () import Prelude.Compat import Control.Arrow ((&&&)) -import Control.Exception hiding (try,catch) import Control.Monad (liftM, liftM2, (<=<), when, forM, forM_) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader (MonadReader,runReaderT,ask,asks) import qualified Data.ByteString as BS @@ -118,10 +117,19 @@ readPackageUnresolvedBS :: (MonadThrow m) -> BS.ByteString -> m ([PWarning],GenericPackageDescription) readPackageUnresolvedBS mcabalfp bs = - case parsePackageDescription chars of - ParseFailed per -> + case rawParseGPD bs of + Left per -> throwM (PackageInvalidCabalFile mcabalfp per) - ParseOk warnings gpkg -> return (warnings,gpkg) + Right x -> return x + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD :: BS.ByteString + -> Either PError ([PWarning], GenericPackageDescription) +rawParseGPD bs = + case parsePackageDescription chars of + ParseFailed per -> Left per + ParseOk warnings gpkg -> Right (warnings,gpkg) where chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs)) @@ -129,12 +137,12 @@ readPackageUnresolvedBS mcabalfp bs = dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t -- | Reads and exposes the package information -readPackage :: (MonadLogger m, MonadIO m, MonadCatch m) +readPackage :: (MonadLogger m, MonadIO m) => PackageConfig -> Path Abs File -> m ([PWarning],Package) readPackage packageConfig cabalfp = - do (warnings,gpkg) <- readPackageUnresolved cabalfp + do (warnings,gpkg) <- liftIO $ readPackageUnresolved cabalfp return (warnings,resolvePackage packageConfig gpkg) -- | Reads and exposes the package information, from a ByteString @@ -148,7 +156,7 @@ readPackageBS packageConfig bs = -- | Get 'GenericPackageDescription' and 'PackageDescription' reading info -- from given directory. -readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadCatch m) +readPackageDescriptionDir :: (MonadLogger m, MonadIO m, MonadThrow m) => PackageConfig -> Path Abs Dir -> m (GenericPackageDescription, PackageDescription) @@ -562,7 +570,7 @@ allBuildInfo' pkg_descr = [ bi | Just lib <- [library pkg_descr] -- | Get all files referenced by the package. packageDescModulesAndFiles - :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) + :: (MonadLogger m, MonadUnliftIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => PackageDescription -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do @@ -607,7 +615,7 @@ packageDescModulesAndFiles pkg = do foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. -resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m) +resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader (Path Abs File, Path Abs Dir) m) => [String] -> m (Set (Path Abs File)) resolveGlobFiles = liftM (S.fromList . catMaybes . concat) . @@ -634,7 +642,7 @@ resolveGlobFiles = ("Wildcard does not match any files: " <> T.pack glob <> "\n" <> "in directory: " <> T.pack dir) return [] - else throwM e) + else throwIO e) -- | This is a copy/paste of the Cabal library function, but with -- @@ -676,7 +684,7 @@ matchDirFileGlob_ dir filepath = case parseFileGlob filepath of -- | Get all files referenced by the benchmark. benchmarkFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) @@ -699,7 +707,7 @@ benchmarkFiles bench = do -- | Get all files referenced by the test. testFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => TestSuite -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do @@ -724,7 +732,7 @@ testFiles test = do -- | Get all files referenced by the executable. executableFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => Executable -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do @@ -744,7 +752,7 @@ executableFiles exe = do -- | Get all files referenced by the library. libraryFiles - :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) @@ -764,7 +772,7 @@ libraryFiles lib = do build = libBuildInfo lib -- | Get all C sources and extra source files in a build. -buildOtherSources :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader (Path Abs File, Path Abs Dir) m) +buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader (Path Abs File, Path Abs Dir) m) => BuildInfo -> m (Set DotCabalPath) buildOtherSources build = do csources <- liftM @@ -830,13 +838,13 @@ flagMap = M.fromList . map pair data ResolveConditions = ResolveConditions { rcFlags :: Map FlagName Bool - , rcCompilerVersion :: CompilerVersion + , rcCompilerVersion :: CompilerVersion 'CVActual , rcOS :: OS , rcArch :: Arch } -- | Generic a @ResolveConditions@ using sensible defaults. -mkResolveConditions :: CompilerVersion -- ^ Compiler version +mkResolveConditions :: CompilerVersion 'CVActual -- ^ Compiler version -> Platform -- ^ installation target platform -> Map FlagName Bool -- ^ enabled flags -> ResolveConditions @@ -900,7 +908,7 @@ depRange (Dependency _ r) = r -- extensions, plus find any of their module and TemplateHaskell -- dependencies. resolveFilesAndDeps - :: (MonadIO m, MonadLogger m, MonadCatch m, MonadReader (Path Abs File, Path Abs Dir) m) + :: (MonadIO m, MonadLogger m, MonadReader (Path Abs File, Path Abs Dir) m, MonadThrow m) => Maybe String -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. @@ -967,7 +975,7 @@ resolveFilesAndDeps component dirs names0 exts = do -- | Get the dependencies of a Haskell module file. getDependencies - :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m, MonadCatch m, MonadLogger m) + :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m, MonadLogger m) => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File]) getDependencies component dotCabalPath = case dotCabalPath of @@ -996,7 +1004,7 @@ getDependencies component dotCabalPath = -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI - :: (MonadReader (Path Abs File, void) m, MonadIO m, MonadCatch m, MonadLogger m) + :: (MonadReader (Path Abs File, void) m, MonadIO m, MonadLogger m) => FilePath -> m (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do dir <- asks (parent . fst) @@ -1019,7 +1027,7 @@ parseDumpHI dumpHIPath = do T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"')) $ filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI thDepsResolved <- liftM catMaybes $ forM thDeps $ \x -> do - mresolved <- forgivingAbsence (resolveFile dir x) >>= rejectMissingFile + mresolved <- liftIO (forgivingAbsence (resolveFile dir x)) >>= rejectMissingFile when (isNothing mresolved) $ $logWarn $ "Warning: addDependentFile path (Template Haskell) listed in " <> T.pack dumpHIPath <> " does not exist: " <> T.pack x @@ -1154,7 +1162,7 @@ logPossibilities dirs mn = do -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile - :: forall m. (MonadThrow m, MonadIO m, MonadLogger m) + :: forall m. (MonadIO m, MonadLogger m) => Path Abs Dir -- ^ package directory -> m (Path Abs File) findOrGenerateCabalFile pkgDir = do @@ -1162,7 +1170,7 @@ findOrGenerateCabalFile pkgDir = do findCabalFile where findCabalFile :: m (Path Abs File) - findCabalFile = findCabalFile' >>= either throwM return + findCabalFile = findCabalFile' >>= either throwIO return findCabalFile' :: m (Either PackageException (Path Abs File)) findCabalFile' = do @@ -1215,13 +1223,13 @@ buildLogPath package' msuffix = do return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn -resolveOrWarn :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) +resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m) => Text -> (Path Abs Dir -> String -> m (Maybe a)) -> FilePath.FilePath -> m (Maybe a) resolveOrWarn subject resolver path = - do cwd <- getCurrentDir + do cwd <- liftIO getCurrentDir file <- asks fst dir <- asks (parent . fst) result <- resolver dir path @@ -1234,19 +1242,19 @@ resolveOrWarn subject resolver path = -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveFileOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs File)) resolveFileOrWarn = resolveOrWarn "File" f - where f p x = forgivingAbsence (resolveFile p x) >>= rejectMissingFile + where f p x = liftIO (forgivingAbsence (resolveFile p x)) >>= rejectMissingFile -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveDirOrWarn :: (MonadCatch m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) +resolveDirOrWarn :: (MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs Dir)) resolveDirOrWarn = resolveOrWarn "Directory" f - where f p x = forgivingAbsence (resolveDir p x) >>= rejectMissingDir + where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir -- | Extract the @PackageIdentifier@ given an exploded haskell package -- path. diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs index 822dc2b92e..26621e7035 100644 --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -26,12 +26,9 @@ module Stack.PackageDump import Control.Applicative import Control.Arrow ((&&&)) -import Control.Exception.Safe (tryIO) import Control.Monad (liftM) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger) -import Control.Monad.Trans.Control import Data.Attoparsec.Args import Data.Attoparsec.Text as P import Data.Conduit @@ -67,7 +64,7 @@ import System.Process.Read -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global @@ -77,7 +74,7 @@ ghcPkgDump = ghcPkgCmdArgs ["dump"] -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => PackageName -> EnvOverride -> WhichCompiler @@ -88,7 +85,7 @@ ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNa -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => [String] -> EnvOverride -> WhichCompiler @@ -117,7 +114,7 @@ newInstalledCache = liftIO $ InstalledCache <$> newIORef (InstalledCacheInner Ma -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: (MonadLogger m, MonadIO m, MonadBaseControl IO m) +loadInstalledCache :: (MonadLogger m, MonadUnliftIO m) => Path Abs File -> m InstalledCache loadInstalledCache path = do m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty) @@ -298,6 +295,7 @@ data DumpPackage profiling haddock symbols = DumpPackage , dpLibDirs :: ![FilePath] , dpLibraries :: ![Text] , dpHasExposedModules :: !Bool + , dpExposedModules :: ![Text] , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![FilePath] , dpHaddockHtml :: !(Maybe FilePath) @@ -384,6 +382,7 @@ conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries , dpHasExposedModules = not (null libraries || null exposedModules) + , dpExposedModules = T.words $ T.unwords exposedModules , dpDepends = depends , dpHaddockInterfaces = haddockInterfaces , dpHaddockHtml = listToMaybe haddockHtml diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 3d1fad3ebc..24ab16b23d 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -21,27 +21,17 @@ module Stack.PackageIndex ( updateAllIndices , getPackageCaches - , getPackageCachesIO , getPackageVersions - , getPackageVersionsIO , lookupPackageVersions ) where import qualified Codec.Archive.Tar as Tar -import Control.Exception (Exception) -import Control.Exception.Safe (tryIO) -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 (unless, when, liftM, guard) +import Control.Monad.IO.Unlift import Control.Monad.Logger (logDebug, logInfo, logWarn) -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 (($$), (=$), (.|), runConduitRes) +import Data.Conduit (($$), (=$), (.|)) import Data.Conduit.Binary (sinkHandle, sourceHandle, sourceFile, sinkFile) import Data.Conduit.Zlib (ungzip) import Data.Foldable (forM_) @@ -74,7 +64,6 @@ import Network.URI (parseURI) import Path (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 @@ -100,7 +89,7 @@ populateCache index = do $logSticky "Populating index cache ..." lbs <- liftIO $ L.readFile $ Path.toFilePath path loop 0 (Map.empty, HashMap.empty) (Tar.read lbs) - (pis, gitPIs) <- loadPIS `C.catch` \e -> do + (pis, gitPIs) <- loadPIS `catch` \e -> do $logWarn $ "Exception encountered when parsing index tarball: " <> T.pack (show (e :: Tar.FormatError)) $logWarn "Automatically updating index and trying again" @@ -139,7 +128,7 @@ populateCache index = do ident pcNew m - , HashMap.insert gitSHA1 offsetSize hm + , HashMap.insert cabalHash offsetSize hm ) where pcNew = PackageCache @@ -150,18 +139,7 @@ populateCache index = do ((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 + cabalHash = computeCabalHash lbs addJSON :: FromJSON a => (a -> PackageDownload) @@ -258,8 +236,8 @@ updateIndex index = tarFile <- configPackageIndex name oldTarFile <- configPackageIndexOld name oldCacheFile <- configPackageIndexCacheOld name - ignoringAbsence (removeFile oldCacheFile) - runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) + liftIO $ ignoringAbsence (removeFile oldCacheFile) + liftIO $ runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) -- | Update the index tarball via HTTP updateIndexHTTP :: (StackMiniM env m, HasConfig env) @@ -305,8 +283,9 @@ updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = d Just x -> return x manager <- liftIO getGlobalManager root <- configPackageIndexRoot indexName' - logTUF <- embed_ ($logInfo . T.pack . HS.pretty) - let withRepo = HS.withRepository + run <- askRunIO + let logTUF = run . $logInfo . T.pack . HS.pretty + withRepo = HS.withRepository (HS.makeHttpLib manager) [baseURI] HS.defaultRepoOpts @@ -354,15 +333,6 @@ deleteCache indexName' = do Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e) Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) --- | Lookup a package's versions from 'IO'. -getPackageVersionsIO - :: (StackMiniM env m, HasConfig env) - => m (PackageName -> IO (Set Version)) -getPackageVersionsIO = do - getCaches <- getPackageCachesIO - return $ \name -> - fmap (lookupPackageVersions name . fst) getCaches - -- | Get the known versions for a given package from the package caches. -- -- See 'getPackageCaches' for performance notes. @@ -377,27 +347,6 @@ lookupPackageVersions :: PackageName -> Map PackageIdentifier a -> Set Version lookupPackageVersions pkgName pkgCaches = Set.fromList [v | PackageIdentifier n v <- Map.keys pkgCaches, n == pkgName] --- | Access the package caches from 'IO'. --- --- FIXME: This is a temporary solution until a better solution --- to access the package caches from Stack.Build.ConstructPlan --- has been found. -getPackageCachesIO - :: (StackMiniM env m, HasConfig env) - => 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) - toIO m = do - runInBase <- liftBaseWith $ \run -> return (void . run) - return $ do - i <- newIORef (error "Impossible evaluation in toIO") - runInBase $ do - x <- m - liftIO $ writeIORef i x - readIORef i - -- | Load the package caches, or create the caches if necessary. -- -- This has two levels of caching: in memory, and the on-disk cache. So, @@ -405,7 +354,7 @@ getPackageCachesIO = toIO getPackageCaches getPackageCaches :: (StackMiniM env m, HasConfig env) => m ( Map PackageIdentifier (PackageIndex, PackageCache) - , HashMap GitSHA1 (PackageIndex, OffsetSize) + , HashMap CabalHash (PackageIndex, OffsetSize) ) getPackageCaches = do config <- view configL @@ -416,7 +365,7 @@ getPackageCaches = do result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do fp <- configPackageIndexCache (indexName index) PackageCacheMap pis' gitPIs <- - $(versionedDecodeOrLoad (storeVersionConfig "pkg-v2" "WlAvAaRXlIMkjSmg5G3dD16UpT8=" + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v4" "YZ4KNwqz-WdTZMaiU0UvfLWSSBw=" :: VersionConfig PackageCacheMap)) fp (populateCache index) diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs new file mode 100644 index 0000000000..b145991423 --- /dev/null +++ b/src/Stack/PackageLocation.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Deal with downloading, cloning, or whatever else is necessary for +-- getting a 'PackageLocation' into something Stack can work with. +module Stack.PackageLocation + ( resolveSinglePackageLocation + , resolveMultiPackageLocation + , loadSingleRawCabalFile + , loadMultiRawCabalFiles + , loadMultiRawCabalFilesIndex + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Zip as Zip +import Control.Arrow (second) +import qualified Codec.Compression.GZip as GZip +import Control.Monad +import Control.Monad.IO.Unlift +import Control.Monad.Logger +import Crypto.Hash (hashWith, SHA256(..)) +import qualified Data.ByteArray as Mem (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Client (parseUrlThrow) +import Network.HTTP.Download (download) +import Path +import Path.Extra +import Path.IO +import Stack.Package +import Stack.Types.BuildPlan +import Stack.Types.Config +import Stack.Types.PackageIdentifier +import System.IO (withBinaryFile, IOMode (ReadMode)) +import System.Process.Read +import System.Process.Run + +-- | Same as 'resolveMultiPackageLocation', but works on a +-- 'SinglePackageLocation'. +resolveSinglePackageLocation + :: (StackMiniM env m, HasConfig env) + => EnvOverride + -> Path Abs Dir -- ^ project root + -> PackageLocation FilePath + -> m (Path Abs Dir) +resolveSinglePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp +resolveSinglePackageLocation _ projRoot (PLHttp url subdir) = do + workDir <- view workDirL + + -- TODO: dedupe with code for snapshot hash? + let name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 url + root = projRoot workDir $(mkRelDir "downloaded") + fileExtension' = ".http-archive" + + fileRel <- parseRelFile $ name ++ fileExtension' + dirRel <- parseRelDir name + dirRelTmp <- parseRelDir $ name ++ ".tmp" + let file = root fileRel + dir = root dirRel + + exists <- doesDirExist dir + unless exists $ do + liftIO $ ignoringAbsence (removeDirRecur dir) + + let dirTmp = root dirRelTmp + liftIO $ ignoringAbsence (removeDirRecur dirTmp) + + let fp = toFilePath file + req <- parseUrlThrow $ T.unpack url + _ <- download req file + + let tryTar = do + $logDebug $ "Trying to untar " <> T.pack fp + liftIO $ withBinaryFile fp ReadMode $ \h -> do + lbs <- L.hGetContents h + let entries = Tar.read $ GZip.decompress lbs + Tar.unpack (toFilePath dirTmp) entries + tryZip = do + $logDebug $ "Trying to unzip " <> T.pack fp + archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp + liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination + (toFilePath dirTmp)] archive + err = throwM $ UnableToExtractArchive url file + + catchAnyLog goodpath handler = + catchAny goodpath $ \e -> do + $logDebug $ "Got exception: " <> T.pack (show e) + handler + + tryTar `catchAnyLog` tryZip `catchAnyLog` err + renameDir dirTmp dir + + x <- listDir dir + case x of + ([dir'], []) -> resolveDir dir' subdir + (dirs, files) -> liftIO $ do + ignoringAbsence (removeFile file) + ignoringAbsence (removeDirRecur dir) + throwIO $ UnexpectedArchiveContents dirs files +resolveSinglePackageLocation menv projRoot (PLRepo (Repo url commit repoType' subdir)) = + cloneRepo menv projRoot url commit repoType' >>= flip resolveDir subdir + +-- | Resolve a PackageLocation into a path, downloading and cloning as +-- necessary. +-- +-- Returns the updated PackageLocation value with just a single subdir +-- (if relevant). +resolveMultiPackageLocation + :: (StackMiniM env m, HasConfig env) + => EnvOverride + -> Path Abs Dir -- ^ project root + -> PackageLocation [FilePath] + -> m [(Path Abs Dir, PackageLocation FilePath)] +resolveMultiPackageLocation x y (PLFilePath fp) = do + dir <- resolveSinglePackageLocation x y (PLFilePath fp) + return [(dir, PLFilePath fp)] +resolveMultiPackageLocation x y (PLHttp url subdirs) = do + dir <- resolveSinglePackageLocation x y (PLHttp url ".") + forM subdirs $ \subdir -> do + dir' <- resolveDir dir subdir + return (dir', PLHttp url subdir) +resolveMultiPackageLocation menv projRoot (PLRepo (Repo url commit repoType' subdirs)) = do + dir <- cloneRepo menv projRoot url commit repoType' + + forM subdirs $ \subdir -> do + dir' <- resolveDir dir subdir + return (dir', PLRepo $ Repo url commit repoType' subdir) + +cloneRepo + :: (StackMiniM env m, HasConfig env) + => EnvOverride + -> Path Abs Dir -- ^ project root + -> Text -- ^ URL + -> Text -- ^ commit + -> RepoType + -> m (Path Abs Dir) +cloneRepo menv projRoot url commit repoType' = do + workDir <- view workDirL + let nameBeforeHashing = case repoType' of + RepoGit -> T.unwords [url, commit] + RepoHg -> T.unwords [url, commit, "hg"] + -- TODO: dedupe with code for snapshot hash? + name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing + root = projRoot workDir $(mkRelDir "downloaded") + + dirRel <- parseRelDir name + let dir = root dirRel + + exists <- doesDirExist dir + unless exists $ do + liftIO $ ignoringAbsence (removeDirRecur dir) + + let cloneAndExtract commandName cloneArgs resetCommand = do + ensureDir root + callProcessInheritStderrStdout Cmd + { cmdDirectoryToRunIn = Just root + , cmdCommandToRun = commandName + , cmdEnvOverride = menv + , cmdCommandLineArguments = + "clone" : + cloneArgs ++ + [ T.unpack url + , toFilePathNoTrailingSep dir + ] + } + created <- doesDirExist dir + unless created $ throwM $ FailedToCloneRepo commandName + readProcessNull (Just dir) menv commandName + (resetCommand ++ [T.unpack commit, "--"]) + `catch` \case + ex@ProcessFailed{} -> do + $logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url + throwM ex + ex -> throwM ex + + case repoType' of + RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] + RepoHg -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] + + return dir + +-- | Load the raw bytes in the cabal files present in the given +-- 'SinglePackageLocation'. +loadSingleRawCabalFile + :: forall m env. + (StackMiniM env m, HasConfig env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index + -> EnvOverride + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> PackageLocationIndex FilePath + -> m ByteString +-- Need special handling of PLIndex for efficiency (just read from the +-- index tarball) and correctness (get the cabal file from the index, +-- not the package tarball itself, yay Hackage revisions). +loadSingleRawCabalFile loadFromIndex _ _ (PLIndex pir) = liftIO $ loadFromIndex pir +loadSingleRawCabalFile _ menv root (PLOther loc) = + resolveSinglePackageLocation menv root loc >>= + findOrGenerateCabalFile >>= + liftIO . S.readFile . toFilePath + +-- | Same as 'loadMultiRawCabalFiles' but for 'PackageLocationIndex'. +loadMultiRawCabalFilesIndex + :: forall m env. + (StackMiniM env m, HasConfig env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index + -> EnvOverride + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> PackageLocationIndex [FilePath] + -> m [(ByteString, PackageLocationIndex FilePath)] +-- Need special handling of PLIndex for efficiency (just read from the +-- index tarball) and correctness (get the cabal file from the index, +-- not the package tarball itself, yay Hackage revisions). +loadMultiRawCabalFilesIndex loadFromIndex _ _ (PLIndex pir) = do + bs <- liftIO $ loadFromIndex pir + return [(bs, PLIndex pir)] +loadMultiRawCabalFilesIndex _ x y (PLOther z) = + map (second PLOther) <$> loadMultiRawCabalFiles x y z + +-- | Same as 'loadSingleRawCabalFile', but for 'PackageLocation' There +-- may be multiple results if dealing with a repository with subdirs, +-- in which case the returned 'PackageLocation' will have just the +-- relevant subdirectory selected. +loadMultiRawCabalFiles + :: forall m env. + (StackMiniM env m, HasConfig env) + => EnvOverride + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> PackageLocation [FilePath] + -> m [(ByteString, PackageLocation FilePath)] +loadMultiRawCabalFiles menv root loc = + resolveMultiPackageLocation menv root loc >>= mapM go + where + go (dir, loc') = do + cabalFile <- findOrGenerateCabalFile dir + bs <- liftIO $ S.readFile $ toFilePath cabalFile + return (bs, loc') diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index 958acfd6f1..347d75f07c 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -7,10 +7,9 @@ module Stack.Path , pathParser ) where -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.Trans.Control import Data.List (intercalate) import Data.Maybe.Extra import Data.Monoid @@ -32,8 +31,8 @@ import System.Process.Read (EnvOverride(eoPath)) -- | Print out useful path information in a human-readable format (and -- support others later). path - :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasEnvConfig env, - MonadCatch m, MonadLogger m) + :: (MonadUnliftIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, + MonadLogger m) => [Text] -> m () path keys = diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index 138514b5f3..492f6c9ce4 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -15,7 +15,7 @@ module Stack.PrettyPrint -- | These are preferred to colors directly, so that we can -- encourage consistency of color meanings. , errorRed, goodGreen, shellMagenta - , displayTargetPkgId, displayCurrentPkgId, displayErrorPkgId + , displayTargetPkgId, displayCurrentPkgId, displayCurrentPkgName, displayErrorPkgId , displayMilliseconds -- * Formatting utils , bulletedList @@ -29,7 +29,7 @@ module Stack.PrettyPrint , enclose, squotes, dquotes, parens, angles, braces, brackets ) where -import Control.Exception.Lifted +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader import Data.List (intersperse) @@ -38,6 +38,7 @@ import Data.String (fromString) import qualified Data.Text as T import Language.Haskell.TH import Path +import Stack.Types.Config import Stack.Types.Internal import Stack.Types.Package import Stack.Types.PackageIdentifier @@ -88,7 +89,7 @@ debugBracket = do output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> msg <> line <> "Exception thrown: " <> fromString (show ex) - throw (ex :: SomeException) + throwIO (ex :: SomeException) end <- liftIO $ Clock.getTime Clock.Monotonic let diff = Clock.diffTimeSpec start end output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg @@ -113,6 +114,9 @@ displayTargetPkgId = cyan . display displayCurrentPkgId :: PackageIdentifier -> AnsiDoc displayCurrentPkgId = yellow . display +displayCurrentPkgName :: PackageName -> AnsiDoc +displayCurrentPkgName = yellow . display + displayErrorPkgId :: PackageIdentifier -> AnsiDoc displayErrorPkgId = errorRed . display diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 4cf53e8bad..4cec14744f 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -20,9 +21,7 @@ module Stack.Runners import Control.Monad hiding (forM) import Control.Monad.Logger -import Control.Exception.Lifted as EL -import Control.Monad.IO.Class -import Control.Monad.Trans.Control +import Control.Monad.IO.Unlift import Data.IORef import Data.Traversable import Path @@ -31,7 +30,7 @@ import Stack.Config import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup -import Stack.Types.Compiler (CompilerVersion) +import Stack.Types.Compiler (CompilerVersion, CVType (..)) import Stack.Types.Config import Stack.Types.StackT import System.Environment (getEnvironment) @@ -40,7 +39,7 @@ import System.FileLock loadCompilerVersion :: GlobalOpts -> LoadConfig (StackT () IO) - -> IO CompilerVersion + -> IO (CompilerVersion 'CVWanted) loadCompilerVersion go lc = do bconfig <- runStackTGlobal () go $ lcLoadBuildConfig lc (globalCompiler go) @@ -53,7 +52,7 @@ loadCompilerVersion go lc = do -- stack uses locks per-snapshot. In the future, stack may refine -- this to an even more fine-grain locking approach. -- -withUserFileLock :: (MonadBaseControl IO m, MonadIO m) +withUserFileLock :: MonadUnliftIO m => GlobalOpts -> Path Abs Dir -> (Maybe FileLock -> m a) @@ -68,19 +67,19 @@ withUserFileLock go@GlobalOpts{} dir act = do ensureDir dir -- Just in case of asynchronous exceptions, we need to be careful -- when using tryLockFile here: - EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) - (maybe (return ()) (liftIO . unlockFile)) - (\fstTry -> + bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive) + (maybe (return ()) (liftIO . unlockFile)) + (\fstTry -> case fstTry of - Just lk -> EL.finally (act $ Just lk) (liftIO $ unlockFile lk) + Just lk -> finally (act $ Just lk) (liftIO $ unlockFile lk) Nothing -> do let chatter = globalLogLevel go /= LevelOther "silent" when chatter $ liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ "); other stack instance running. Waiting..." - EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive) - (liftIO . unlockFile) - (\lk -> do + bracket (liftIO $ lockFile (toFilePath pth) Exclusive) + (liftIO . unlockFile) + (\lk -> do when chatter $ liftIO $ hPutStrLn stderr "Lock acquired, proceeding." act $ Just lk)) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 5d8924469b..6fdb1f667e 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -11,6 +11,7 @@ module Stack.SDist ( getSDistTarball , checkSDistTarball , checkSDistTarball' + , SDistOpts (..) ) where import qualified Codec.Archive.Tar as Tar @@ -18,16 +19,17 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (unless, void, liftM) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad (unless, liftM, filterM, when) +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (liftBaseWith) +import Control.Monad.Reader.Class (local) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Data.Char (toLower) import Data.Data (Data, Typeable, cast, gmapT) import Data.Either (partitionEithers) +import Data.IORef (newIORef, readIORef, writeIORef) import Data.List import Data.List.Extra (nubOrd) import Data.List.NonEmpty (NonEmpty) @@ -42,21 +44,26 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Time.Clock.POSIX import Distribution.Package (Dependency (..)) +import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Check as Check import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Text (display) import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) import Distribution.Version.Extra +import Lens.Micro (set) import Path import Path.IO hiding (getModificationTime, getPermissions) import Prelude -- Fix redundant import warnings -import Stack.Build (mkBaseConfigOpts) +import Stack.Build (mkBaseConfigOpts, build) import Stack.Build.Execute import Stack.Build.Installed import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig) -import Stack.Build.Target +import Stack.Build.Target hiding (PackageType (..)) +import Stack.PackageLocation (resolveMultiPackageLocation) import Stack.Constants import Stack.Package import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier @@ -70,6 +77,21 @@ import qualified System.FilePath as FP -- | Special exception to throw when you want to fail because of bad results -- of package check. +data SDistOpts = SDistOpts + { sdoptsDirsToWorkWith :: [String] + -- ^ Directories to package + , sdoptsPvpBounds :: Maybe PvpBounds + -- ^ PVP Bounds overrides + , sdoptsIgnoreCheck :: Bool + -- ^ Whether to ignore check of the package for common errors + , sdoptsSign :: Bool + -- ^ Whether to sign the package + , sdoptsSignServerUrl :: String + -- ^ The URL of the signature server + , sdoptsBuildTarball :: Bool + -- ^ Whether to build the tarball + } + newtype CheckException = CheckException (NonEmpty Check.PackageCheck) deriving (Typeable) @@ -91,10 +113,11 @@ getSDistTarball :: (StackM env m, HasEnvConfig env) => Maybe PvpBounds -- ^ Override Config value -> Path Abs Dir -- ^ Path to local package - -> m (FilePath, L.ByteString) -- ^ Filename and tarball contents + -> m (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString)) + -- ^ Filename, tarball contents, and option cabal file revision to upload getSDistTarball mpvpBounds pkgDir = do config <- view configL - let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds + let PvpBounds pvpBounds asRevision = fromMaybe (configPvpBounds config) mpvpBounds tweakCabal = pvpBounds /= PvpBoundsNone pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir @@ -102,6 +125,13 @@ getSDistTarball mpvpBounds pkgDir = do (fileList, cabalfp) <- getSDistFileList lp $logInfo $ "Building sdist tarball for " <> T.pack pkgFp files <- normalizeTarballPaths (lines fileList) + + -- We're going to loop below and eventually find the cabal + -- file. When we do, we'll upload this reference, if the + -- mpvpBounds value indicates that we should be uploading a cabal + -- file revision. + cabalFileRevisionRef <- liftIO (newIORef Nothing) + -- NOTE: Could make this use lazy I/O to only read files as needed -- for upload (both GZip.compress and Tar.write are lazy). -- However, it seems less error prone and more predictable to read @@ -116,8 +146,16 @@ getSDistTarball mpvpBounds pkgDir = do packWith f isDir fp = liftIO $ f (pkgFp FP. fp) =<< tarPath isDir fp packDir = packWith Tar.packDirectoryEntry True packFile fp + -- This is a cabal file, we're going to tweak it, but only + -- tweak it as a revision. + | tweakCabal && isCabalFp fp && asRevision = do + lbsIdent <- getCabalLbs pvpBounds (Just 1) $ toFilePath cabalfp + liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent)) + packWith packFileEntry False fp + -- Same, except we'll include the cabal file in the + -- original tarball upload. | tweakCabal && isCabalFp fp = do - lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp + (_ident, lbs) <- getCabalLbs pvpBounds Nothing $ toFilePath cabalfp currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch tp <- liftIO $ tarPath False fp return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime } @@ -127,11 +165,16 @@ getSDistTarball mpvpBounds pkgDir = do pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) dirEntries <- mapM packDir (dirsFromFiles files) fileEntries <- mapM packFile files - return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries))) + mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef) + return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision) -- | Get the PVP bounds-enabled version of the given cabal file -getCabalLbs :: (StackM env m, HasEnvConfig env) => PvpBounds -> FilePath -> m L.ByteString -getCabalLbs pvpBounds fp = do +getCabalLbs :: (StackM env m, HasEnvConfig env) + => PvpBoundsType + -> Maybe Int -- ^ optional revision + -> FilePath + -> m (PackageIdentifier, L.ByteString) +getCabalLbs pvpBounds mrev fp = do bs <- liftIO $ S.readFile fp (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI @@ -143,7 +186,24 @@ getCabalLbs pvpBounds fp = do } sourceMap let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd - return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd' + gpd'' = + case mrev of + Nothing -> gpd' + Just rev -> gpd' + { Cabal.packageDescription + = (Cabal.packageDescription gpd') + { Cabal.customFieldsPD + = (("x-revision", show rev):) + $ filter (\(x, _) -> map toLower x /= "x-revision") + $ Cabal.customFieldsPD + $ Cabal.packageDescription gpd' + } + } + ident <- parsePackageIdentifierFromString $ display $ Cabal.package $ Cabal.packageDescription gpd'' + return + ( ident + , TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'' + ) where addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency addBounds sourceMap installedMap dep@(Dependency cname range) = @@ -212,19 +272,19 @@ readLocalPackage pkgDir = do -- | Returns a newline-separate list of paths, and the absolute path to the .cabal file. getSDistFileList :: (StackM env m, HasEnvConfig env) => LocalPackage -> m (String, Path Abs File) getSDistFileList lp = - withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do + withRunIO $ \run -> withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> run $ do menv <- getMinimalEnvOverride let bopts = defaultBuildOpts let boptsCli = defaultBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli (locals, _) <- loadSourceMap NeedTargets boptsCli - runInBase <- liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO withExecuteEnv menv bopts boptsCli baseConfigOpts locals [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files $ \ee -> withSingleContext runInBase ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" - cabal False ["sdist", "--list-sources", outFile] + cabal KeepTHLoading ["sdist", "--list-sources", outFile] contents <- liftIO (readFile outFile) return (contents, cabalfp) where @@ -239,6 +299,7 @@ getSDistFileList lp = } , taskPresent = Map.empty , taskAllInOne = True + , taskCachePkgSrc = CacheSrcLocal (toFilePath (lpDir lp)) } normalizeTarballPaths :: (StackM env m) => [FilePath] -> m [FilePath] @@ -275,12 +336,20 @@ dirsFromFiles dirs = Set.toAscList (Set.delete "." results) -- -- Note that we temporarily decompress the archive to analyze it. checkSDistTarball :: (StackM env m, HasEnvConfig env) - => Path Abs File -- ^ Absolute path to tarball + => SDistOpts -- ^ The configuration of what to check + -> Path Abs File -- ^ Absolute path to tarball -> m () -checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do +checkSDistTarball opts tarball = withTempTarGzContents tarball $ \pkgDir' -> do pkgDir <- (pkgDir' ) `liftM` (parseRelDir . FP.takeBaseName . FP.takeBaseName . toFilePath $ tarball) -- ^ drop ".tar" ^ drop ".gz" + when (sdoptsBuildTarball opts) (buildExtractedTarball pkgDir) + unless (sdoptsIgnoreCheck opts) (checkPackageInExtractedTarball pkgDir) + +checkPackageInExtractedTarball :: (StackM env m, HasEnvConfig env) + => Path Abs Dir -- ^ Absolute path to tarball + -> m () +checkPackageInExtractedTarball pkgDir = do cabalfp <- findOrGenerateCabalFile pkgDir name <- parsePackageNameFromFilePath cabalfp config <- getDefaultPackageConfig @@ -302,22 +371,55 @@ checkSDistTarball tarball = withTempTarGzContents tarball $ \pkgDir' -> do Nothing -> return () Just ne -> throwM $ CheckException ne +buildExtractedTarball :: (StackM env m, HasEnvConfig env) => Path Abs Dir -> m () +buildExtractedTarball pkgDir = do + projectRoot <- view projectRootL + envConfig <- view envConfigL + menv <- getMinimalEnvOverride + localPackageToBuild <- readLocalPackage pkgDir + let packageEntries = bcPackages (envConfigBuildConfig envConfig) + getPaths = resolveMultiPackageLocation menv projectRoot + allPackagePaths <- fmap (map fst . mconcat) (mapM getPaths packageEntries) + -- We remove the path based on the name of the package + let isPathToRemove path = do + localPackage <- readLocalPackage path + return $ packageName (lpPackage localPackage) == packageName (lpPackage localPackageToBuild) + pathsToKeep <- filterM (fmap not . isPathToRemove) allPackagePaths + newPackagesRef <- liftIO (newIORef Nothing) + let adjustEnvForBuild env = + let updatedEnvConfig = envConfig + {envConfigPackagesRef = newPackagesRef + ,envConfigBuildConfig = updatePackageInBuildConfig (envConfigBuildConfig envConfig) + } + in set envConfigL updatedEnvConfig env + updatePackageInBuildConfig buildConfig = buildConfig + { bcPackages = map (PLFilePath . toFilePath) $ pkgDir : pathsToKeep + , bcConfig = (bcConfig buildConfig) + { configBuild = defaultBuildOpts + { boptsTests = True + } + } + } + local adjustEnvForBuild $ + build (const (return ())) Nothing defaultBuildOptsCLI + -- | Version of 'checkSDistTarball' that first saves lazy bytestring to -- temporary directory and then calls 'checkSDistTarball' on it. checkSDistTarball' :: (StackM env m, HasEnvConfig env) - => String -- ^ Tarball name + => SDistOpts + -> String -- ^ Tarball name -> L.ByteString -- ^ Tarball contents as a byte string -> m () -checkSDistTarball' name bytes = withSystemTempDir "stack" $ \tpath -> do +checkSDistTarball' opts name bytes = withRunIO $ \run -> withSystemTempDir "stack" $ \tpath -> run $ do npath <- (tpath ) `liftM` parseRelFile name liftIO $ L.writeFile (toFilePath npath) bytes - checkSDistTarball npath + checkSDistTarball opts npath -withTempTarGzContents :: (MonadIO m, MonadMask m) +withTempTarGzContents :: (MonadUnliftIO m) => Path Abs File -- ^ Location of tarball -> (Path Abs Dir -> m a) -- ^ Perform actions given dir with tarball contents -> m a -withTempTarGzContents apath f = withSystemTempDir "stack" $ \tpath -> do +withTempTarGzContents apath f = withRunIO $ \run -> withSystemTempDir "stack" $ \tpath -> run $ do archive <- liftIO $ L.readFile (toFilePath apath) liftIO . Tar.unpack (toFilePath tpath) . Tar.read . GZip.decompress $ archive f tpath diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 2f35d4406f..0c69dbef70 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -5,10 +5,8 @@ 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 (unless, forM, void) +import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 @@ -20,13 +18,10 @@ 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 @@ -35,7 +30,6 @@ 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 Stack.Types.StringError import System.FilePath (dropExtension, replaceExtension) @@ -66,15 +60,16 @@ scriptCmd opts go' = do menv <- liftIO $ configEnvOverride config defaultEnvSettings wc <- view $ actualCompilerVersionL.whichCompilerL - (targetsSet, coresSet) <- + targetsSet <- case soPackages opts of [] -> do - $logError "No packages provided, using experimental import parser" - getPackagesFromImports (globalResolver go) (soFile opts) + -- Using the import parser + moduleInfo <- view $ loadedSnapshotL.to toModuleInfo + getPackagesFromModuleInfo moduleInfo (soFile opts) packages -> do let targets = concatMap wordsComma packages targets' <- mapM parsePackageNameFromString targets - return (Set.fromList targets', Set.empty) + return $ Set.fromList targets' unless (Set.null targetsSet) $ do -- Optimization: use the relatively cheap ghc-pkg list @@ -102,7 +97,7 @@ scriptCmd opts go' = do , map (\x -> "-package" ++ x) $ Set.toList $ Set.insert "base" - $ Set.map packageNameString (Set.union targetsSet coresSet) + $ Set.map packageNameString targetsSet , case soCompile opts of SEInterpret -> [] SECompile -> [] @@ -142,19 +137,12 @@ isWindows = True 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 +getPackagesFromModuleInfo + :: ModuleInfo + -> FilePath -- ^ script filename + -> StackT EnvConfig IO (Set PackageName) +getPackagesFromModuleInfo mi scriptFP = do (pns1, mns) <- liftIO $ parseImports <$> S8.readFile scriptFP - mi <- loadModuleInfo name pns2 <- if Set.null mns then return Set.empty @@ -173,14 +161,7 @@ getPackagesFromImports (Just (ARResolver (ResolverSnapshot name))) scriptFP = do ] 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 + return $ Set.union pns1 pns2 -- | The Stackage project introduced the concept of hidden packages, -- to deal with conflicting module names. However, this is a @@ -234,40 +215,32 @@ blacklist = Set.fromList , $(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 +toModuleInfo :: LoadedSnapshot -> ModuleInfo +toModuleInfo ls = + mconcat + $ map (\(pn, lpi) -> + ModuleInfo + $ Map.fromList + $ map (\mn -> (mn, Set.singleton pn)) + $ Set.toList + $ lpiExposedModules lpi) + $ filter (\(pn, lpi) -> + not (lpiHide lpi) && + pn `Set.notMember` blacklist) + $ Map.toList + $ Map.union (void <$> lsPackages ls) (void <$> lsGlobals ls) parseImports :: ByteString -> (Set PackageName, Set ModuleName) parseImports = - fold . mapMaybe parseLine . S8.lines + fold . mapMaybe (parseLine . stripCR) . S8.lines where + -- Remove any carriage return character present at the end, to + -- support Windows-style line endings (CRLF) + stripCR bs + | S8.null bs = bs + | S8.last bs == '\r' = S8.init bs + | otherwise = bs + stripPrefix x y | x `S8.isPrefixOf` y = Just $ S8.drop (S8.length x) y | otherwise = Nothing diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 3840a9abb5..a3df7c523d 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10 {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -33,15 +34,12 @@ module Stack.Setup import qualified Codec.Archive.Tar as Tar import Control.Applicative -import Control.Concurrent.Async.Lifted (Concurrently(..)) -import Control.Exception.Safe (catchIO, tryAny) -import Control.Monad (liftM, when, join, void, unless, guard) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.Async (Concurrently(..)) +import Control.Monad (liftM, when, join, unless, guard) +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader (MonadReader, ReaderT (..)) import Control.Monad.State (get, put, modify) -import Control.Monad.Trans.Control import "cryptonite" Crypto.Hash (SHA1(..)) import Data.Aeson.Extended import qualified Data.ByteString as S @@ -81,6 +79,7 @@ import Lens.Micro (set) import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode) import Network.HTTP.Download import Path +import Path.CheckInstall (warnInstallSearchPathIssues) import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (findExecutable) import qualified Paths_stack as Meta @@ -94,6 +93,7 @@ import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath) import Stack.PrettyPrint import Stack.Setup.Installed +import Stack.Snapshot (loadSnapshot) import Stack.Types.Build import Stack.Types.Compiler import Stack.Types.CompilerBuild @@ -128,7 +128,7 @@ data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool -- ^ Should we use a system compiler installation, if available? - , soptsWantedCompiler :: !CompilerVersion + , soptsWantedCompiler :: !(CompilerVersion 'CVWanted) , soptsCompilerCheck :: !VersionCheck , soptsStackYaml :: !(Maybe (Path Abs File)) -- ^ If we got the desired GHC version from that file @@ -154,7 +154,7 @@ data SetupOpts = SetupOpts deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownCompilerVersion Text CompilerVersion [CompilerVersion] + | UnknownCompilerVersion Text (CompilerVersion 'CVWanted) [CompilerVersion 'CVActual] | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) | WantedMustBeGHC @@ -251,20 +251,33 @@ setupEnv mResolveMissingGHC = do <$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0) menv <- mkEnvOverride platform env - (compilerVer, cabalVer, globaldb) <- runConcurrently $ (,,) - <$> Concurrently (getCompilerVersion menv wc) - <*> Concurrently (getCabalPkgVer menv wc) - <*> Concurrently (getGlobalDB menv wc) + (compilerVer, cabalVer, globaldb) <- withUnliftIO $ \u -> runConcurrently $ (,,) + <$> Concurrently (unliftIO u $ getCompilerVersion menv wc) + <*> Concurrently (unliftIO u $ getCabalPkgVer menv wc) + <*> Concurrently (unliftIO u $ getGlobalDB menv wc) $logDebug "Resolving package entries" packagesRef <- liftIO $ newIORef Nothing bc <- view buildConfigL + + -- Set up a modified environment which includes the modified PATH + -- that GHC can be found on. This is needed for looking up global + -- package information in loadSnapshot. + let bcPath :: BuildConfig + bcPath = set envOverrideL (const (return menv)) bc + + ls <- runInnerStackT bcPath $ loadSnapshot + menv + (Just compilerVer) + (view projectRootL bc) + (bcSnapshotDef bc) let envConfig0 = EnvConfig { envConfigBuildConfig = bc , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer , envConfigCompilerBuild = compilerBuild , envConfigPackagesRef = packagesRef + , envConfigLoadedSnapshot = ls } -- extra installation bin directories @@ -344,6 +357,7 @@ setupEnv mResolveMissingGHC = do , envConfigCompilerVersion = compilerVer , envConfigCompilerBuild = compilerBuild , envConfigPackagesRef = envConfigPackagesRef envConfig0 + , envConfigLoadedSnapshot = ls } -- | Add the include and lib paths to the given Config @@ -636,7 +650,7 @@ upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env) upgradeCabal menv wc cabalVersion = do $logInfo "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") - rmap <- resolvePackages Nothing Map.empty (Set.singleton name) + rmap <- resolvePackages Nothing mempty (Set.singleton name) installed <- getCabalPkgVer menv wc case cabalVersion of Specific version -> do @@ -663,7 +677,7 @@ doCabalInstall :: (StackM env m, HasConfig env, HasGHCVariant env) -> Version -> m () doCabalInstall menv wc installed version = do - withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do + withRunIO $ \run -> withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> run $ do $logInfo $ T.concat [ "Installing Cabal-" , T.pack $ versionString version @@ -672,7 +686,7 @@ doCabalInstall menv wc installed version = do ] let name = $(mkPackageName "Cabal") ident = PackageIdentifier name version - m <- unpackPackageIdents tmpdir Nothing (Map.singleton ident Nothing) + m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident Nothing] compilerPath <- join $ findExecutable menv (compilerExeName wc) versionDir <- parseRelDir $ versionString version let installRoot = toFilePath $ parent (parent compilerPath) @@ -698,7 +712,8 @@ doCabalInstall menv wc installed version = do $logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available -getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch)) +getSystemCompiler :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) + => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion 'CVActual, Arch)) getSystemCompiler menv wc = do let exeName = case wc of Ghc -> "ghc" @@ -765,7 +780,7 @@ getInstalledTool installed name goodVersion = goodPackage _ = Nothing getInstalledGhcjs :: [Tool] - -> (CompilerVersion -> Bool) + -> (CompilerVersion 'CVActual -> Bool) -> Maybe Tool getInstalledGhcjs installed goodVersion = if null available @@ -788,18 +803,18 @@ downloadAndInstallTool programsDir si downloadInfo tool installer = do (file, at) <- downloadFromInfo programsDir downloadInfo tool dir <- installDir programsDir tool tempDir <- tempInstallDir programsDir tool - ignoringAbsence (removeDirRecur tempDir) + liftIO $ ignoringAbsence (removeDirRecur tempDir) ensureDir tempDir unmarkInstalled programsDir tool installer si file at tempDir dir markInstalled programsDir tool - ignoringAbsence (removeDirRecur tempDir) + liftIO $ ignoringAbsence (removeDirRecur tempDir) return tool downloadAndInstallCompiler :: (StackM env m, HasConfig env, HasGHCVariant env) => CompilerBuild -> SetupInfo - -> CompilerVersion + -> CompilerVersion 'CVWanted -> VersionCheck -> Maybe String -> m Tool @@ -855,8 +870,8 @@ downloadAndInstallCompiler compilerBuild si wanted versionCheck _mbindistUrl = d getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text -> VersionCheck - -> CompilerVersion - -> (k -> CompilerVersion) + -> CompilerVersion 'CVWanted + -> (k -> CompilerVersion 'CVActual) -> Map k a -> m (k, a) getWantedCompilerInfo key versionCheck wanted toCV pairs_ = @@ -869,7 +884,7 @@ getWantedCompilerInfo key versionCheck wanted toCV pairs_ = sortBy (flip (comparing fst)) $ filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) -getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadCatch m) +getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) => CompilerBuild -> m Text getGhcKey ghcBuild = do ghcVariant <- view ghcVariantL @@ -1060,8 +1075,8 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do $logDebug $ "ziptool: " <> T.pack zipTool $logDebug $ "tar: " <> T.pack tarTool return $ do - ignoringAbsence (removeDirRecur destDir) - ignoringAbsence (removeDirRecur unpackDir) + liftIO $ ignoringAbsence (removeDirRecur destDir) + liftIO $ ignoringAbsence (removeDirRecur unpackDir) readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile] innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir @@ -1093,12 +1108,12 @@ installGHCJS si archiveFile archiveType _tempDir destDir = do (_, files) <- listDir (dir $(mkRelDir "bin")) forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do let dest = destDir $(mkRelDir "bin") filename optionsFile - ignoringAbsence (removeFile dest) + liftIO $ ignoringAbsence (removeFile dest) copyFile optionsFile dest $logStickyDone "Installed GHCJS." ensureGhcjsBooted :: (StackM env m, HasConfig env) - => EnvOverride -> CompilerVersion -> Bool -> [String] -> m () + => EnvOverride -> CompilerVersion 'CVActual -> Bool -> [String] -> m () ensureGhcjsBooted menv cv shouldBoot bootOpts = do eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) case eres of @@ -1203,11 +1218,11 @@ loadGhcjsEnvConfig stackYaml binPath = runInnerStackT () $ do bconfig <- lcLoadBuildConfig lc Nothing runInnerStackT bconfig $ setupEnv Nothing -getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m) +getCabalInstallVersion :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> m (Maybe Version) getCabalInstallVersion menv = do ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] - case ebs of + liftIO $ case ebs of Left _ -> return Nothing Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs)) @@ -1320,8 +1335,8 @@ withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do run7z <- setup7z si let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" ensureDir (parent destDir) - withTempDir (parent destDir) tmpName $ \tmpDir -> do - ignoringAbsence (removeDirRecur destDir) + withRunIO $ \run -> withTempDir (parent destDir) tmpName $ \tmpDir -> run $ do + liftIO $ ignoringAbsence (removeDirRecur destDir) run7z (parent archiveFile) archiveFile run7z tmpDir tarFile absSrcDir <- case msrcDir of @@ -1412,7 +1427,7 @@ chattyDownload label downloadInfo path = do , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } - runInBase <- liftBaseWith $ \run -> return (void . run) + runInBase <- askRunIO x <- verifiedDownload dReq path (chattyDownloadProgress runInBase) if x then $logStickyDone ("Downloaded " <> label <> ".") @@ -1495,25 +1510,25 @@ chunksOverTime diff = do go -- | Perform a basic sanity check of GHC -sanityCheck :: (MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m) +sanityCheck :: (MonadUnliftIO m, MonadLogger m) => EnvOverride -> WhichCompiler -> m () -sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do +sanityCheck menv wc = withRunIO $ \run -> withSystemTempDir "stack-sanity-check" $ \dir -> run $ do let fp = toFilePath $ dir $(mkRelFile "Main.hs") liftIO $ writeFile fp $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present , "main = putStrLn \"Hello World\"" ] let exeName = compilerExeName wc - ghc <- join $ findExecutable menv exeName + ghc <- liftIO $ join $ findExecutable menv exeName $logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc) eres <- tryProcessStdout (Just dir) menv exeName [ fp , "-no-user-package-db" ] case eres of - Left e -> throwM $ GHCSanityCheckCompileFailed e ghc + Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct -- Remove potentially confusing environment variables @@ -1530,8 +1545,8 @@ removeHaskellEnvVars = -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars :: forall m env. - (MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> CompilerVersion -> m (Map Text Text) + (MonadReader env m, HasPlatform env, MonadLogger m, MonadUnliftIO m) + => EnvOverride -> CompilerVersion 'CVActual -> m (Map Text Text) getUtf8EnvVars menv compilerVer = if getGhcVersion compilerVer >= $(mkVersion "7.10.3") -- GHC_CHARENC supported by GHC >=7.10.3 @@ -1765,6 +1780,9 @@ downloadStackExe platforms0 archiveInfo destDir testExe = do renameFile tmpFile destFile _ -> renameFile tmpFile destFile + destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir + warnInstallSearchPathIssues destDir' ["stack"] + $logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile where diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index 5ac8d1fde2..9c99765bc9 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,11 +23,9 @@ module Stack.Setup.Installed ) where import Control.Applicative -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import Data.List hiding (concat, elem, maximumBy) import Data.Maybe @@ -51,7 +50,7 @@ import System.Process.Read data Tool = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512 - | ToolGhcjs CompilerVersion -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 + | ToolGhcjs (CompilerVersion 'CVActual) -- ^ e.g. ghcjs-0.1.0_ghc-7.10.2 toolString :: Tool -> String toolString (Tool ident) = packageIdentifierString ident @@ -74,11 +73,11 @@ markInstalled programsPath tool = do fpRel <- parseRelFile $ toolString tool ++ ".installed" liftIO $ writeFile (toFilePath $ programsPath fpRel) "installed" -unmarkInstalled :: (MonadIO m, MonadCatch m) +unmarkInstalled :: MonadIO m => Path Abs Dir -> Tool -> m () -unmarkInstalled programsPath tool = do +unmarkInstalled programsPath tool = liftIO $ do fpRel <- parseRelFile $ toolString tool ++ ".installed" ignoringAbsence (removeFile $ programsPath fpRel) @@ -95,8 +94,8 @@ listInstalled programsPath = do x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp parseToolText x -getCompilerVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> WhichCompiler -> m CompilerVersion +getCompilerVersion :: (MonadLogger m, MonadUnliftIO m, MonadThrow m) + => EnvOverride -> WhichCompiler -> m (CompilerVersion 'CVActual) getCompilerVersion menv wc = case wc of Ghc -> do @@ -142,6 +141,7 @@ extraDirs tool = do ] , edLib = [ dir $(mkRelDir "mingw32") $(mkRelDir "lib") + , dir $(mkRelDir "mingw32") $(mkRelDir "bin") ] } (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty @@ -155,6 +155,7 @@ extraDirs tool = do ] , edLib = [ dir $(mkRelDir "mingw64") $(mkRelDir "lib") + , dir $(mkRelDir "mingw64") $(mkRelDir "bin") ] } (_, isGHC -> True) -> return mempty @@ -188,13 +189,13 @@ installDir :: (MonadReader env m, MonadThrow m) -> Tool -> m (Path Abs Dir) installDir programsDir tool = do - reldir <- parseRelDir $ toolString tool - return $ programsDir reldir + relativeDir <- parseRelDir $ toolString tool + return $ programsDir relativeDir tempInstallDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir -> Tool -> m (Path Abs Dir) tempInstallDir programsDir tool = do - reldir <- parseRelDir $ toolString tool ++ ".temp" - return $ programsDir reldir + relativeDir <- parseRelDir $ toolString tool ++ ".temp" + return $ programsDir relativeDir diff --git a/src/Stack/SetupCmd.hs b/src/Stack/SetupCmd.hs index 0d8034f879..f24defeeca 100644 --- a/src/Stack/SetupCmd.hs +++ b/src/Stack/SetupCmd.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -28,7 +29,7 @@ import Stack.Types.StackT import Stack.Types.Version data SetupCmdOpts = SetupCmdOpts - { scoCompilerVersion :: !(Maybe CompilerVersion) + { scoCompilerVersion :: !(Maybe (CompilerVersion 'CVWanted)) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !(Maybe UpgradeTo) , scoSetupInfoYaml :: !String @@ -103,7 +104,7 @@ setupParser = SetupCmdOpts setup :: (StackM env m, HasConfig env, HasGHCVariant env) => SetupCmdOpts - -> CompilerVersion + -> CompilerVersion 'CVWanted -> VersionCheck -> Maybe (Path Abs File) -> m () diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs index 7f715afdee..4b6f2abb1f 100644 --- a/src/Stack/Sig/GPG.hs +++ b/src/Stack/Sig/GPG.hs @@ -19,8 +19,7 @@ import Prelude () import Prelude.Compat import Control.Monad (unless, when) -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger, logWarn) import qualified Data.ByteString.Char8 as C import Data.List (find, isPrefixOf) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index 75c4c9afea..a46df93b5e 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -22,8 +22,7 @@ import Prelude.Compat import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Monad (when) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as L @@ -45,12 +44,13 @@ import qualified System.FilePath as FP -- service and a path to a tarball. sign #if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) + :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) #else - :: (MonadIO m, MonadLogger m, MonadMask m) + :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) #endif => String -> Path Abs File -> m Signature sign url filePath = + withRunIO $ \run -> withSystemTempDir "stack" (\tempDir -> @@ -64,7 +64,7 @@ sign url filePath = Nothing -> throwM SigInvalidSDistTarBall Just cabalPath -> do pkg <- cabalFilePackageId (tempDir cabalPath) - signPackage url pkg filePath) + run (signPackage url pkg filePath)) where extractCabalFile tempDir (Tar.Next entry entries) = case Tar.entryContent entry of @@ -90,18 +90,19 @@ sign url filePath = -- the tarball with GPG. signTarBytes #if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadIO m, MonadLogger m, MonadMask m) + :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) #else - :: (MonadIO m, MonadLogger m, MonadMask m) + :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) #endif => String -> Path Rel File -> L.ByteString -> m Signature signTarBytes url tarPath bs = + withRunIO $ \run -> withSystemTempDir "stack" (\tempDir -> do let tempTarBall = tempDir tarPath liftIO (L.writeFile (toFilePath tempTarBall) bs) - sign url tempTarBall) + run (sign url tempTarBall)) -- | Sign a haskell package given the url to the signature service, a -- @PackageIdentifier@ and a file path to the package on disk. diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs new file mode 100644 index 0000000000..e87e416825 --- /dev/null +++ b/src/Stack/Snapshot.hs @@ -0,0 +1,795 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Reading in @SnapshotDef@s and converting them into +-- @LoadedSnapshot@s. +module Stack.Snapshot + ( loadResolver + , loadSnapshot + , calculatePackagePromotion + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Monad (forM, unless, void, (>=>), when, forM_) +import Control.Monad.IO.Unlift +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader) +import Control.Monad.State.Strict (get, put, StateT, execStateT) +import Crypto.Hash (hash, SHA256(..), Digest) +import Crypto.Hash.Conduit (hashFile) +import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) +import Data.Aeson.Extended (WithJSONWarnings(..), logJSONWarnings, (..!=), (..:?), jsonSubWarningsT, withObjectWarnings, (..:)) +import Data.Aeson.Types (Parser, parseEither) +import Data.Store.VersionTagged +import qualified Data.ByteArray as Mem (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString.Char8 as S8 +import Data.Conduit ((.|)) +import qualified Data.Conduit.List as CL +import qualified Data.HashMap.Strict as HashMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import Data.Yaml (decodeFileEither, ParseException (AesonException)) +import Distribution.InstalledPackageInfo (PError) +import Distribution.PackageDescription (GenericPackageDescription) +import qualified Distribution.PackageDescription as C +import Distribution.System (Platform) +import Distribution.Text (display) +import qualified Distribution.Version as C +import Network.HTTP.Client (Request) +import Network.HTTP.Download +import Path +import Path.IO +import Prelude -- Fix AMP warning +import Stack.Constants +import Stack.Fetch +import Stack.Package +import Stack.PackageDump +import Stack.PackageLocation +import Stack.Types.BuildPlan +import Stack.Types.FlagName +import Stack.Types.GhcPkgId +import Stack.Types.PackageIdentifier +import Stack.Types.PackageName +import Stack.Types.Version +import Stack.Types.VersionIntervals +import Stack.Types.Config +import Stack.Types.Urls +import Stack.Types.Compiler +import Stack.Types.Resolver +import Stack.Types.StackT +import System.Process.Read (EnvOverride) + +type SinglePackageLocation = PackageLocationIndex FilePath + +data SnapshotException + = InvalidCabalFileInSnapshot !SinglePackageLocation !PError !ByteString + | PackageDefinedTwice !PackageName !SinglePackageLocation !SinglePackageLocation + | UnmetDeps !(Map PackageName (Map PackageName (VersionIntervals, Maybe Version))) + | FilepathInCustomSnapshot !Text + | NeedResolverOrCompiler !Text + | MissingPackages !(Set PackageName) + deriving Typeable +instance Exception SnapshotException +instance Show SnapshotException where + show (InvalidCabalFileInSnapshot loc err _bs) = concat + [ "Invalid cabal file at " + , show loc + , ": " + , show err + ] + show (PackageDefinedTwice name loc1 loc2) = concat + [ "Package " + , packageNameString name + , " is defined twice, at " + , show loc1 + , " and " + , show loc2 + ] + show (UnmetDeps m) = + concat $ "Some dependencies in the snapshot are unmet.\n" : map go (Map.toList m) + where + go (name, deps) = concat + $ "\n" + : packageNameString name + : " is missing:\n" + : map goDep (Map.toList deps) + + goDep (dep, (intervals, mversion)) = concat + [ "- " + , packageNameString dep + , ". Requires: " + , display $ toVersionRange intervals + , ", " + , case mversion of + Nothing -> "none present" + Just version -> versionString version ++ " found" + , "\n" + ] + show (FilepathInCustomSnapshot url) = + "Custom snapshots do not support filepaths, as the contents may change over time. Found in: " ++ + T.unpack url + show (NeedResolverOrCompiler url) = + "You must specify either a resolver or compiler value in " ++ + T.unpack url + show (MissingPackages names) = + "The following packages specified by flags or options are not found: " ++ + unwords (map packageNameString (Set.toList names)) + +-- | Convert a 'Resolver' into a 'SnapshotDef' +loadResolver + :: forall env m. + (StackMiniM env m, HasConfig env) + => Resolver + -> m SnapshotDef +loadResolver (ResolverSnapshot name) = do + stackage <- view stackRootL + file' <- parseRelFile $ T.unpack file + let fp = buildPlanDir stackage file' + tryDecode = liftIO $ do + evalue <- decodeFileEither $ toFilePath fp + return $ + case evalue of + Left e -> Left e + Right value -> + case parseEither parseStackageSnapshot value of + Left s -> Left $ AesonException s + Right x -> Right x + $logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) + eres <- tryDecode + case eres of + Right sd -> return sd + Left e -> do + $logDebug $ "Decoding Stackage snapshot definition from file failed: " <> T.pack (show e) + ensureDir (parent fp) + url <- buildBuildPlanUrl name file + req <- parseRequest $ T.unpack url + $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." + $logDebug $ "Downloading build plan from: " <> url + _ <- redownload req fp + $logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." + tryDecode >>= either throwM return + + where + file = renderSnapName name <> ".yaml" + + buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text + buildBuildPlanUrl snapName file' = do + urls <- view $ configL.to configUrls + return $ + case snapName of + LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file' + Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> file' + + parseStackageSnapshot = withObject "StackageSnapshotDef" $ \o -> do + Object si <- o .: "system-info" + ghcVersion <- si .:? "ghc-version" + compilerVersion <- si .:? "compiler-version" + compilerVersion' <- + case (ghcVersion, compilerVersion) of + (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" + (Just ghc, _) -> return (GhcVersion ghc) + (_, Just compiler) -> return compiler + _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" + let sdParent = Left compilerVersion' + sdGlobalHints <- si .: "core-packages" + + packages <- o .: "packages" + (Endo mkLocs, sdFlags, sdHidden) <- fmap mconcat $ mapM (uncurry goPkg) $ Map.toList packages + let sdLocations = mkLocs [] + + let sdGhcOptions = Map.empty -- Stackage snapshots do not allow setting GHC options + + -- Not dropping any packages in a Stackage snapshot + let sdDropPackages = Set.empty + + let sdResolver = ResolverSnapshot name + sdResolverName = renderSnapName name + + return SnapshotDef {..} + where + goPkg name' = withObject "StackagePackageDef" $ \o -> do + version <- o .: "version" + mcabalFileInfo <- o .:? "cabal-file-info" + mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do + cfiSize <- Just <$> o' .: "size" + cfiHashes <- o' .: "hashes" + cfiHash <- + case HashMap.lookup ("SHA256" :: Text) cfiHashes of + Nothing -> fail "Could not find SHA256" + Just shaText -> + case mkCabalHashFromSHA256 shaText of + Nothing -> fail "Invalid SHA256" + Just x -> return x + return CabalFileInfo {..} + + Object constraints <- o .: "constraints" + + flags <- constraints .: "flags" + let flags' = Map.singleton name' flags + + hide <- constraints .:? "hide" .!= False + let hide' = if hide then Map.singleton name' True else Map.empty + + let location = PLIndex $ PackageIdentifierRevision (PackageIdentifier name' version) mcabalFileInfo' + + return (Endo (location:), flags', hide') +loadResolver (ResolverCompiler compiler) = return SnapshotDef + { sdParent = Left compiler + , sdResolver = ResolverCompiler compiler + , sdResolverName = compilerVersionText compiler + , sdLocations = [] + , sdDropPackages = Set.empty + , sdFlags = Map.empty + , sdHidden = Map.empty + , sdGhcOptions = Map.empty + , sdGlobalHints = Map.empty + } +loadResolver (ResolverCustom url loc) = do + $logDebug $ "Loading " <> url <> " build plan" + case loc of + Left req -> download' req >>= load + Right fp -> load fp + where + download' :: Request -> m (Path Abs File) + download' req = do + let urlHash = S8.unpack $ trimmedSnapshotHash $ doHash $ encodeUtf8 url + hashFP <- parseRelFile $ urlHash ++ ".yaml" + customPlanDir <- getCustomPlanDir + let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP + void (download req cacheFP :: m Bool) + return cacheFP + + getCustomPlanDir = do + root <- view stackRootL + return $ root $(mkRelDir "custom-plan") + + load :: Path Abs File -> m SnapshotDef + load fp = do + WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- + liftIO (decodeFileEither (toFilePath fp)) >>= either + throwM + (either (throwM . AesonException) return . parseEither parseCustom) + logJSONWarnings (T.unpack url) warnings + + forM_ (sdLocations sd0) $ \loc' -> + case loc' of + PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url + _ -> return () + + -- The fp above may just be the download location for a URL, + -- which we don't want to use. Instead, look back at loc from + -- above. + let mdir = + case loc of + Left _ -> Nothing + Right fp' -> Just $ parent fp' + + -- Deal with the dual nature of the compiler key, which either + -- means "use this compiler" or "override the compiler in the + -- resolver" + (parentResolver, overrideCompiler) <- + case (mparentResolver, mcompiler) of + (Nothing, Nothing) -> throwM $ NeedResolverOrCompiler url + (Just parentResolver, Nothing) -> return (parentResolver, id) + (Nothing, Just compiler) -> return (ResolverCompiler compiler, id) + (Just parentResolver, Just compiler) -> return + ( parentResolver + , setCompilerVersion compiler + ) + + parentResolver' <- parseCustomLocation mdir parentResolver + + -- Calculate the hash of the current file, and then combine it + -- with parent hashes if necessary below. + rawHash :: SnapshotHash <- fromDigest <$> hashFile (toFilePath fp) :: m SnapshotHash + + (parent', hash') <- + case parentResolver' of + ResolverCompiler cv -> return (Left cv, rawHash) -- just a small optimization + _ -> do + parent' :: SnapshotDef <- loadResolver (parentResolver' :: Resolver) :: m SnapshotDef + let hash' :: SnapshotHash + hash' = combineHash rawHash $ + case sdResolver parent' of + ResolverSnapshot snapName -> snapNameToHash snapName + ResolverCustom _ parentHash -> parentHash + ResolverCompiler _ -> error "loadResolver: Receieved ResolverCompiler in impossible location" + return (Right parent', hash') + return $ overrideCompiler sd0 + { sdParent = parent' + , sdResolver = ResolverCustom url hash' + } + + -- | Note that the 'sdParent' and 'sdResolver' fields returned + -- here are bogus, and need to be replaced with information only + -- available after further processing. + parseCustom :: Value + -> Parser (WithJSONWarnings (SnapshotDef, Maybe (ResolverWith ()), Maybe (CompilerVersion 'CVWanted))) + parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,) + <$> (SnapshotDef (Left (error "loadResolver")) (ResolverSnapshot (LTS 0 0)) + <$> (o ..: "name") + <*> jsonSubWarningsT (o ..:? "packages" ..!= []) + <*> o ..:? "drop-packages" ..!= Set.empty + <*> o ..:? "flags" ..!= Map.empty + <*> o ..:? "hidden" ..!= Map.empty + <*> o ..:? "ghc-options" ..!= Map.empty + <*> o ..:? "global-hints" ..!= Map.empty) + <*> (o ..:? "resolver") + <*> (o ..:? "compiler") + + fromDigest :: Digest SHA256 -> SnapshotHash + fromDigest = SnapshotHash . B64URL.encode . Mem.convert + + combineHash :: SnapshotHash -> SnapshotHash -> SnapshotHash + combineHash (SnapshotHash x) (SnapshotHash y) = doHash (x <> y) + + snapNameToHash :: SnapName -> SnapshotHash + snapNameToHash = doHash . encodeUtf8 . renderSnapName + + doHash :: ByteString -> SnapshotHash + doHash = fromDigest . hash + +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' +loadSnapshot + :: forall env m. + (StackMiniM env m, HasConfig env, HasGHCVariant env) + => EnvOverride -- ^ used for running Git/Hg, and if relevant, getting global package info + -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> SnapshotDef + -> m LoadedSnapshot +loadSnapshot menv mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader menv mcompiler root sd + +-- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' +loadSnapshot' + :: forall env m. + (StackMiniM env m, HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ load a cabal file's contents from the index + -> EnvOverride -- ^ used for running Git/Hg, and if relevant, getting global package info + -> Maybe (CompilerVersion 'CVActual) -- ^ installed GHC we should query; if none provided, use the global hints + -> Path Abs Dir -- ^ project root, used for checking out necessary files + -> SnapshotDef + -> m LoadedSnapshot +loadSnapshot' loadFromIndex menv mcompiler root = + start + where + start (snapshotDefFixes -> sd) = do + path <- configLoadedSnapshotCache + sd + (maybe GISSnapshotHints GISCompiler mcompiler) + $(versionedDecodeOrLoad loadedSnapshotVC) path (inner sd) + + inner :: SnapshotDef -> m LoadedSnapshot + inner sd = do + ls0 <- + case sdParent sd of + Left cv -> + case mcompiler of + Nothing -> return LoadedSnapshot + { lsCompilerVersion = wantedToActual cv + , lsGlobals = fromGlobalHints $ sdGlobalHints sd + , lsPackages = Map.empty + } + Just cv' -> loadCompiler cv' + Right sd' -> start sd' + + gpds <- concat <$> mapM + (loadMultiRawCabalFilesIndex loadFromIndex menv root >=> mapM parseGPD) + (sdLocations sd) + + (globals, snapshot, locals, _upgraded) <- + calculatePackagePromotion loadFromIndex menv root ls0 + (map (\(x, y) -> (x, y, ())) gpds) + (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd) + + return LoadedSnapshot + { lsCompilerVersion = lsCompilerVersion ls0 + , lsGlobals = globals + -- When applying a snapshot on top of another one, we merge + -- the two snapshots' packages together. + , lsPackages = Map.union snapshot (Map.map (fmap fst) locals) + } + +-- | Given information on a 'LoadedSnapshot' and a given set of +-- additional packages and configuration values, calculates the new +-- global and snapshot packages, as well as the new local packages. +-- +-- The new globals and snapshots must be a subset of the initial +-- values. +calculatePackagePromotion + :: forall env m localLocation. + (StackMiniM env m, HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) -- ^ load from index + -> EnvOverride + -> Path Abs Dir -- ^ project root + -> LoadedSnapshot + -> [(GenericPackageDescription, SinglePackageLocation, localLocation)] -- ^ packages we want to add on top of this snapshot + -> Map PackageName (Map FlagName Bool) -- ^ flags + -> Map PackageName Bool -- ^ overrides whether a package should be registered hidden + -> Map PackageName [Text] -- ^ GHC options + -> Set PackageName -- ^ packages in the snapshot to drop + -> m ( Map PackageName (LoadedPackageInfo GhcPkgId) -- new globals + , Map PackageName (LoadedPackageInfo SinglePackageLocation) -- new snapshot + , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals + , Set PackageName -- packages explicitly upgraded via flags/options/hide values + ) +calculatePackagePromotion + loadFromIndex menv root (LoadedSnapshot compilerVersion globals0 parentPackages0) + gpds flags0 hides0 options0 drops0 = do + + platform <- view platformL + + -- Hand out flags, hide, and GHC options to the newly added + -- packages + (packages1, flags, hide, ghcOptions) <- execStateT + (mapM_ (findPackage platform compilerVersion) gpds) + (Map.empty, flags0, hides0, options0) + + let + -- We need to drop all packages from globals and parent + -- packages that are either marked to be dropped, or + -- included in the new packages. + toDrop = Map.union (void packages1) (Map.fromSet (const ()) drops0) + globals1 = Map.difference globals0 toDrop + parentPackages1 = Map.difference parentPackages0 toDrop + + -- The set of all packages that need to be upgraded based on + -- newly set flags, hide values, or GHC options + toUpgrade = Set.unions [Map.keysSet flags, Map.keysSet hide, Map.keysSet ghcOptions] + + -- Perform a sanity check: ensure that all of the packages + -- that need to be upgraded actually exist in the global or + -- parent packages + oldNames = Set.union (Map.keysSet globals1) (Map.keysSet parentPackages1) + extraToUpgrade = Set.difference toUpgrade oldNames + unless (Set.null extraToUpgrade) $ throwM $ MissingPackages extraToUpgrade + + let + -- Split up the globals into those that are to be upgraded + -- (no longer globals) and those that remain globals, based + -- solely on the toUpgrade value + (noLongerGlobals1, globals2) = Map.partitionWithKey + (\name _ -> name `Set.member` toUpgrade) + globals1 + -- Further: now that we've removed a bunch of packages from + -- globals, split out any packages whose dependencies are no + -- longer met + (globals3, noLongerGlobals2) = splitUnmetDeps Map.empty globals2 + + -- Put together the two split out groups of packages + noLongerGlobals3 :: Map PackageName (LoadedPackageInfo SinglePackageLocation) + noLongerGlobals3 = Map.union (Map.mapWithKey globalToSnapshot noLongerGlobals1) noLongerGlobals2 + + -- Now do the same thing with parent packages: take out the + -- packages to be upgraded and then split out unmet + -- dependencies. + (noLongerParent1, parentPackages2) = Map.partitionWithKey + (\name _ -> name `Set.member` toUpgrade) + parentPackages1 + (parentPackages3, noLongerParent2) = splitUnmetDeps + (Map.map lpiVersion globals3) + parentPackages2 + noLongerParent3 = Map.union noLongerParent1 noLongerParent2 + + -- Everything split off from globals and parents will be upgraded... + allToUpgrade = Map.union noLongerGlobals3 noLongerParent3 + + -- ... so recalculate based on new values + upgraded <- fmap Map.fromList + $ mapM (recalculate loadFromIndex menv root compilerVersion flags hide ghcOptions) + $ Map.toList allToUpgrade + + -- Could be nice to check snapshot early... but disabling + -- because ConstructPlan gives much nicer error messages + let packages2 = Map.unions [Map.map void upgraded, Map.map void packages1, Map.map void parentPackages3] + allAvailable = Map.union + (lpiVersion <$> globals3) + (lpiVersion <$> packages2) + when False $ checkDepsMet allAvailable packages2 + + unless (Map.null (globals3 `Map.difference` globals0)) + (error "calculatePackagePromotion: subset invariant violated for globals") + unless (Map.null (parentPackages3 `Map.difference` parentPackages0)) + (error "calculatePackagePromotion: subset invariant violated for parents") + + return + ( globals3 + , parentPackages3 + , Map.union (Map.map (fmap (, Nothing)) upgraded) (Map.map (fmap (second Just)) packages1) + , toUpgrade + ) + +-- | Recalculate a 'LoadedPackageInfo' based on updates to flags, +-- hide values, and GHC options. +recalculate :: forall env m. + (StackMiniM env m, HasConfig env, HasGHCVariant env) + => (PackageIdentifierRevision -> IO ByteString) + -> EnvOverride + -> Path Abs Dir -- ^ root + -> CompilerVersion 'CVActual + -> Map PackageName (Map FlagName Bool) + -> Map PackageName Bool -- ^ hide? + -> Map PackageName [Text] -- ^ GHC options + -> (PackageName, LoadedPackageInfo SinglePackageLocation) + -> m (PackageName, LoadedPackageInfo SinglePackageLocation) +recalculate loadFromIndex menv root compilerVersion allFlags allHide allOptions (name, lpi0) = do + let hide = fromMaybe (lpiHide lpi0) (Map.lookup name allHide) + options = fromMaybe (lpiGhcOptions lpi0) (Map.lookup name allOptions) + case Map.lookup name allFlags of + Nothing -> return (name, lpi0 { lpiHide = hide, lpiGhcOptions = options }) -- optimization + Just flags -> do + let loc = lpiLocation lpi0 + gpd <- loadSingleRawCabalFile loadFromIndex menv root loc >>= parseGPDSingle loc + platform <- view platformL + let res@(name', lpi) = calculate gpd platform compilerVersion loc flags hide options + unless (name == name' && lpiVersion lpi0 == lpiVersion lpi) $ error "recalculate invariant violated" + return res + +fromGlobalHints :: Map PackageName (Maybe Version) -> Map PackageName (LoadedPackageInfo GhcPkgId) +fromGlobalHints = + Map.unions . map go . Map.toList + where + go (_, Nothing) = Map.empty + go (name, Just ver) = Map.singleton name LoadedPackageInfo + { lpiVersion = ver + -- For global hint purposes, we only care about the + -- version. All other fields are ignored when checking + -- project compatibility. + , lpiLocation = either impureThrow id + $ parseGhcPkgId + $ packageIdentifierText + $ PackageIdentifier name ver + , lpiFlags = Map.empty + , lpiGhcOptions = [] + , lpiPackageDeps = Map.empty + , lpiProvidedExes = Set.empty + , lpiNeededExes = Map.empty + , lpiExposedModules = Set.empty + , lpiHide = False + } + +-- | Ensure that all of the dependencies needed by this package +-- are available in the given Map of packages. +checkDepsMet :: MonadThrow m + => Map PackageName Version -- ^ all available packages + -> Map PackageName (LoadedPackageInfo localLocation) + -> m () +checkDepsMet available m + | Map.null errs = return () + | otherwise = throwM $ UnmetDeps errs + where + errs = foldMap (uncurry go) (Map.toList m) + + go :: PackageName + -> LoadedPackageInfo loc + -> Map PackageName (Map PackageName (VersionIntervals, Maybe Version)) + go name lpi + | Map.null errs' = Map.empty + | otherwise = Map.singleton name errs' + where + errs' = foldMap (uncurry goDep) (Map.toList (lpiPackageDeps lpi)) + + goDep :: PackageName -> VersionIntervals -> Map PackageName (VersionIntervals, Maybe Version) + goDep name intervals = + case Map.lookup name available of + Nothing -> Map.singleton name (intervals, Nothing) + Just version + | version `withinIntervals` intervals -> Map.empty + | otherwise -> Map.singleton name (intervals, Just version) + +-- | Load a snapshot from the given compiler version, using just the +-- information in the global package database. +loadCompiler :: forall env m. + (StackMiniM env m, HasConfig env) + => CompilerVersion 'CVActual + -> m LoadedSnapshot +loadCompiler cv = do + menv <- getMinimalEnvOverride + m <- ghcPkgDump menv (whichCompiler cv) [] + (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)) + return LoadedSnapshot + { lsCompilerVersion = cv + , lsGlobals = toGlobals m + , lsPackages = Map.empty + } + where + toGlobals :: Map GhcPkgId (DumpPackage () () ()) + -> Map PackageName (LoadedPackageInfo GhcPkgId) + toGlobals m = + Map.fromList $ map go $ Map.elems m + where + identMap = Map.map dpPackageIdent m + + go :: DumpPackage () () () -> (PackageName, LoadedPackageInfo GhcPkgId) + go dp = + (name, lpi) + where + PackageIdentifier name version = dpPackageIdent dp + + goDep ghcPkgId = + case Map.lookup ghcPkgId identMap of + Nothing -> Map.empty + Just (PackageIdentifier name' _) -> Map.singleton name' (fromVersionRange C.anyVersion) + + lpi :: LoadedPackageInfo GhcPkgId + lpi = LoadedPackageInfo + { lpiVersion = version + , lpiLocation = dpGhcPkgId dp + , lpiFlags = Map.empty + , lpiGhcOptions = [] + , lpiPackageDeps = Map.unions $ map goDep $ dpDepends dp + , lpiProvidedExes = Set.empty + , lpiNeededExes = Map.empty + , lpiExposedModules = Set.fromList $ map (ModuleName . encodeUtf8) $ dpExposedModules dp + , lpiHide = not $ dpIsExposed dp + } + +type FindPackageS localLocation = + ( Map PackageName (LoadedPackageInfo (SinglePackageLocation, localLocation)) + , Map PackageName (Map FlagName Bool) -- flags + , Map PackageName Bool -- hide + , Map PackageName [Text] -- ghc options + ) + +-- | Find the package at the given 'PackageLocation', grab any flags, +-- hidden state, and GHC options from the 'StateT' (removing them from +-- the 'StateT'), and add the newly found package to the contained +-- 'Map'. +findPackage :: forall m localLocation. + MonadThrow m + => Platform + -> CompilerVersion 'CVActual + -> (GenericPackageDescription, SinglePackageLocation, localLocation) + -> StateT (FindPackageS localLocation) m () +findPackage platform compilerVersion (gpd, loc, localLoc) = do + (m, allFlags, allHide, allOptions) <- get + + case Map.lookup name m of + Nothing -> return () + Just lpi -> throwM $ PackageDefinedTwice name loc (fst (lpiLocation lpi)) + + let flags = fromMaybe Map.empty $ Map.lookup name allFlags + allFlags' = Map.delete name allFlags + + hide = fromMaybe False $ Map.lookup name allHide + allHide' = Map.delete name allHide + + options = fromMaybe [] $ Map.lookup name allOptions + allOptions' = Map.delete name allOptions + + (name', lpi) = calculate gpd platform compilerVersion (loc, localLoc) flags hide options + m' = Map.insert name lpi m + + assert (name == name') $ put (m', allFlags', allHide', allOptions') + where + PackageIdentifier name _version = fromCabalPackageIdentifier $ C.package $ C.packageDescription gpd + +-- | Some hard-coded fixes for build plans, hopefully to be irrelevant over +-- time. +snapshotDefFixes :: SnapshotDef -> SnapshotDef +snapshotDefFixes sd | isStackage (sdResolver sd) = sd + { sdFlags = Map.unionWith Map.union overrides $ sdFlags sd + } + where + overrides = Map.fromList + [ ($(mkPackageName "persistent-sqlite"), Map.singleton $(mkFlagName "systemlib") False) + , ($(mkPackageName "yaml"), Map.singleton $(mkFlagName "system-libyaml") False) + ] + + isStackage (ResolverSnapshot _) = True + isStackage _ = False +snapshotDefFixes sd = sd + +-- | Convert a global 'LoadedPackageInfo' to a snapshot one by +-- creating a 'PackageLocation'. +globalToSnapshot :: PackageName -> LoadedPackageInfo loc -> LoadedPackageInfo (PackageLocationIndex FilePath) +globalToSnapshot name lpi = lpi + { lpiLocation = PLIndex (PackageIdentifierRevision (PackageIdentifier name (lpiVersion lpi)) Nothing) + } + +-- | Split the globals into those which have their dependencies met, +-- and those that don't. This deals with promotion of globals to +-- snapshot when another global has been upgraded already. +splitUnmetDeps :: Map PackageName Version -- ^ extra dependencies available + -> Map PackageName (LoadedPackageInfo loc) + -> ( Map PackageName (LoadedPackageInfo loc) + , Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath)) + ) +splitUnmetDeps extra = + start Map.empty . Map.toList + where + start newGlobals0 toProcess0 + | anyAdded = start newGlobals1 toProcess1 + | otherwise = (newGlobals1, Map.mapWithKey globalToSnapshot $ Map.fromList toProcess1) + where + (newGlobals1, toProcess1, anyAdded) = loop False newGlobals0 id toProcess0 + + loop anyAdded newGlobals front [] = (newGlobals, front [], anyAdded) + loop anyAdded newGlobals front (x@(k, v):xs) + | depsMet newGlobals v = loop True (Map.insert k v newGlobals) front xs + | otherwise = loop anyAdded newGlobals (front . (x:)) xs + + depsMet globals = all (depsMet' globals) . Map.toList . lpiPackageDeps + + depsMet' globals (name, intervals) = + case (lpiVersion <$> Map.lookup name globals) <|> Map.lookup name extra of + Nothing -> False + Just version -> version `withinIntervals` intervals + +parseGPDSingle :: MonadThrow m => SinglePackageLocation -> ByteString -> m GenericPackageDescription +parseGPDSingle loc bs = + either (\e -> throwM $ InvalidCabalFileInSnapshot loc e bs) (return . snd) + $ rawParseGPD bs + +parseGPD :: MonadThrow m + => ( ByteString -- raw contents + , SinglePackageLocation -- for error reporting + ) + -> m (GenericPackageDescription, SinglePackageLocation) +parseGPD (bs, loc) = do + case rawParseGPD bs of + Left e -> throwM $ InvalidCabalFileInSnapshot loc e bs + Right (_warnings, gpd) -> return (gpd, loc) + +-- | Calculate a 'LoadedPackageInfo' from the given 'GenericPackageDescription' +calculate :: GenericPackageDescription + -> Platform + -> CompilerVersion 'CVActual + -> loc + -> Map FlagName Bool + -> Bool -- ^ hidden? + -> [Text] -- ^ GHC options + -> (PackageName, LoadedPackageInfo loc) +calculate gpd platform compilerVersion loc flags hide options = + (name, lpi) + where + pconfig = PackageConfig + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = False + , packageConfigFlags = flags + , packageConfigGhcOptions = options + , packageConfigCompilerVersion = compilerVersion + , packageConfigPlatform = platform + } + pd = resolvePackageDescription pconfig gpd + PackageIdentifier name version = fromCabalPackageIdentifier $ C.package pd + lpi = LoadedPackageInfo + { lpiVersion = version + , lpiLocation = loc + , lpiFlags = flags + , lpiGhcOptions = options + , lpiPackageDeps = Map.map fromVersionRange + $ Map.filterWithKey (const . (/= name)) + $ packageDependencies pd + , lpiProvidedExes = Set.fromList $ map (ExeName . T.pack . C.exeName) $ C.executables pd + , lpiNeededExes = Map.mapKeys ExeName + $ Map.map fromVersionRange + $ packageToolDependencies pd + , lpiExposedModules = maybe + Set.empty + (Set.fromList . map fromCabalModuleName . C.exposedModules) + (C.library pd) + , lpiHide = hide + } diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 34bb1331fb..d5b6fccc45 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,8 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Stack.Solver - ( checkResolverSpec - , cabalPackagesCheck + ( cabalPackagesCheck , findCabalFiles , getResolverConstraints , mergeConstraints @@ -21,11 +21,8 @@ import Prelude () import Prelude.Compat import Control.Applicative -import Control.Exception (assert) -import Control.Exception.Safe (tryIO) import Control.Monad (when,void,join,liftM,unless,mapAndUnzipM, zipWithM_) -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.Aeson.Extended (object, (.=), toJSON) import qualified Data.ByteString as S @@ -59,6 +56,7 @@ import qualified Distribution.Text as C import Path import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles) +import Stack.Build.Target (gpdVersion) import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) @@ -68,7 +66,9 @@ import Stack.Package (printCabalFileWarning import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed +import Stack.Snapshot (loadSnapshot) import Stack.Types.Build +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -97,7 +97,7 @@ cabalSolver :: (StackM env m, HasConfig env) -> m (Either [PackageName] ConstraintSpec) cabalSolver menv cabalfps constraintType srcConstraints depConstraints cabalArgs = - withSystemTempDir "cabal-solver" $ \dir' -> do + withRunIO $ \run -> withSystemTempDir "cabal-solver" $ \dir' -> run $ do let versionConstraints = fmap fst depConstraints dir = toFilePath dir' @@ -277,7 +277,7 @@ getCabalConfig dir constraintType constraints = do setupCompiler :: (StackM env m, HasConfig env, HasGHCVariant env) - => CompilerVersion + => CompilerVersion 'CVWanted -> m (Maybe ExtraDirs) setupCompiler compiler = do let msg = Just $ T.concat @@ -308,8 +308,8 @@ setupCompiler compiler = do setupCabalEnv :: (StackM env m, HasConfig env, HasGHCVariant env) - => CompilerVersion - -> m EnvOverride + => CompilerVersion 'CVWanted + -> m (EnvOverride, CompilerVersion 'CVActual) setupCabalEnv compiler = do mpaths <- setupCompiler compiler menv0 <- getMinimalEnvOverride @@ -335,12 +335,13 @@ setupCabalEnv compiler = do | otherwise -> return () mver <- getSystemCompiler menv (whichCompiler compiler) - case mver of - Just (version, _) -> + version <- case mver of + Just (version, _) -> do $logInfo $ "Using compiler: " <> compilerVersionText version + return version Nothing -> error "Failed to determine compiler version. \ \This is most likely a bug." - return menv + return (menv, version) -- | Merge two separate maps, one defining constraints on package versions and -- the other defining package flagmap, into a single map of version and flagmap @@ -374,7 +375,7 @@ solveResolverSpec :: (StackM env m, HasConfig env, HasGHCVariant env) => Path Abs File -- ^ stack.yaml file location -> [Path Abs Dir] -- ^ package dirs containing cabal files - -> ( Resolver + -> ( SnapshotDef , ConstraintSpec , ConstraintSpec) -- ^ ( resolver -- , src package constraints @@ -384,10 +385,11 @@ solveResolverSpec -- (resulting src package specs, external dependency specs)) solveResolverSpec stackYaml cabalDirs - (resolver, srcConstraints, extraConstraints) = do - $logInfo $ "Using resolver: " <> resolverName resolver - (compilerVer, snapConstraints) <- getResolverConstraints stackYaml resolver - menv <- setupCabalEnv compilerVer + (sd, srcConstraints, extraConstraints) = do + $logInfo $ "Using resolver: " <> sdResolverName sd + let wantedCompilerVersion = sdWantedCompilerVersion sd + (menv, compilerVersion) <- setupCabalEnv wantedCompilerVersion + (compilerVer, snapConstraints) <- getResolverConstraints menv (Just compilerVersion) stackYaml sd let -- Note - The order in Map.union below is important. -- We want to override snapshot with extra deps @@ -402,7 +404,7 @@ solveResolverSpec stackYaml cabalDirs ["--ghcjs" | whichCompiler compilerVer == Ghcjs] let srcNames = T.intercalate " and " $ - ["packages from " <> resolverName resolver + ["packages from " <> sdResolverName sd | not (Map.null snapConstraints)] ++ [T.pack (show (Map.size extraConstraints) <> " external packages") | not (Map.null extraConstraints)] @@ -479,35 +481,20 @@ solveResolverSpec stackYaml cabalDirs -- for that resolver. getResolverConstraints :: (StackM env m, HasConfig env, HasGHCVariant env) - => Path Abs File - -> Resolver - -> m (CompilerVersion, + => EnvOverride -- ^ for running Git/Hg clone commands + -> Maybe (CompilerVersion 'CVActual) -- ^ actually installed compiler + -> Path Abs File + -> SnapshotDef + -> m (CompilerVersion 'CVActual, Map PackageName (Version, Map FlagName Bool)) -getResolverConstraints stackYaml resolver = do - (mbp, _loadedResolver) <- loadResolver (Just stackYaml) resolver - return (mbpCompilerVersion mbp, mbpConstraints mbp) +getResolverConstraints menv mcompilerVersion stackYaml sd = do + ls <- loadSnapshot menv mcompilerVersion (parent stackYaml) sd + return (lsCompilerVersion ls, lsConstraints ls) where - mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi) - mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp) - --- | Given a bundle of user packages, flag constraints on those packages and a --- resolver, determine if the resolver fully, partially or fails to satisfy the --- dependencies of the user packages. --- --- If the package flags are passed as 'Nothing' then flags are chosen --- automatically. -checkResolverSpec - :: (StackM env m, HasConfig env, HasGHCVariant env) - => [C.GenericPackageDescription] - -> Maybe (Map PackageName (Map FlagName Bool)) - -> Resolver - -> m BuildPlanCheck -checkResolverSpec gpds flags resolver = do - case resolver of - ResolverSnapshot name -> checkSnapBuildPlan gpds flags name - ResolverCompiler {} -> return $ BuildPlanCheckPartial Map.empty Map.empty - -- TODO support custom resolver for stack init - ResolverCustom {} -> return $ BuildPlanCheckPartial Map.empty Map.empty + lpiConstraints lpi = (lpiVersion lpi, lpiFlags lpi) + lsConstraints ls = Map.union + (Map.map lpiConstraints (lsPackages ls)) + (Map.map lpiConstraints (lsGlobals ls)) -- | Finds all files with a .cabal extension under a given directory. If -- a `hpack` `package.yaml` file exists, this will be used to generate a cabal @@ -638,25 +625,27 @@ solveExtraDeps modStackYaml = do relStackYaml <- prettyPath stackYaml $logInfo $ "Using configuration file: " <> T.pack relStackYaml - packages <- getLocalPackages - let cabalDirs = Map.keys packages - noPkgMsg = "No cabal packages found in " <> relStackYaml <> + lp <- getLocalPackages + let packages = lpProject lp + let noPkgMsg = "No cabal packages found in " <> relStackYaml <> ". Please add at least one directory containing a .cabal \ \file. You can also use 'stack init' to automatically \ \generate the config file." dupPkgFooter = "Please remove the directories containing duplicate \ \entries from '" <> relStackYaml <> "'." - cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs) + cabalDirs = map lpvRoot $ Map.elems packages + cabalfps = map lpvCabalFP $ Map.elems packages -- TODO when solver supports --ignore-subdirs option pass that as the -- second argument here. reportMissingCabalFiles cabalfps True (bundle, _) <- cabalPackagesCheck cabalfps noPkgMsg (Just dupPkgFooter) let gpds = Map.elems $ fmap snd bundle - oldFlags = unPackageFlags (bcFlags bconfig) - oldExtraVersions = bcExtraDeps bconfig - resolver = bcResolver bconfig + oldFlags = bcFlags bconfig + oldExtraVersions = Map.map (gpdVersion . fst) (lpDependencies lp) + sd = bcSnapshotDef bconfig + resolver = sdResolver sd oldSrcs = gpdPackages gpds oldSrcFlags = Map.intersection oldFlags oldSrcs oldExtraFlags = Map.intersection oldFlags oldExtraVersions @@ -664,19 +653,18 @@ solveExtraDeps modStackYaml = do srcConstraints = mergeConstraints oldSrcs oldSrcFlags extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags - let resolver' = toResolverNotLoaded resolver - resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver' + resolverResult <- checkSnapBuildPlan (parent stackYaml) gpds (Just oldSrcFlags) sd resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) BuildPlanCheckPartial {} -> do eres <- solveResolverSpec stackYaml cabalDirs - (resolver', srcConstraints, extraConstraints) + (sd, srcConstraints, extraConstraints) -- TODO Solver should also use the init code to ignore incompatible -- packages return $ either (const Nothing) Just eres BuildPlanCheckFail {} -> - throwM $ ResolverMismatch IsSolverCmd resolver (show resolverResult) + throwM $ ResolverMismatch IsSolverCmd (sdResolverName sd) (show resolverResult) (srcs, edeps) <- case resultSpecs of Nothing -> throwM (SolverGiveUp giveUpMsg) @@ -700,14 +688,14 @@ solveExtraDeps modStackYaml = do changed = any (not . Map.null) [newVersions, goneVersions] || any (not . Map.null) [newFlags, goneFlags] - || any (/= resolver') mOldResolver + || any (/= void resolver) (fmap void mOldResolver) if changed then do $logInfo "" $logInfo $ "The following changes will be made to " <> T.pack relStackYaml <> ":" - printResolver mOldResolver resolver' + printResolver (fmap void mOldResolver) (void resolver) printFlags newFlags "* Flags to be added" printDeps newVersions "* Dependencies to be added" @@ -733,9 +721,9 @@ solveExtraDeps modStackYaml = do when (res /= oldRes) $ do $logInfo $ T.concat [ "* Resolver changes from " - , resolverName oldRes + , resolverRawName oldRes , " to " - , resolverName res + , resolverRawName res ] printFlags fl msg = do @@ -759,7 +747,7 @@ solveExtraDeps modStackYaml = do HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList deps) $ HashMap.insert ("flags" :: Text) (toJSON fl) - $ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj + $ HashMap.insert ("resolver" :: Text) (toJSON res) obj liftIO $ Yaml.encodeFile fp obj' giveUpMsg = concat diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 17fc2996d9..7d2defa517 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -18,6 +18,7 @@ module Stack.Types.Build ,Installed(..) ,PackageInstallInfo(..) ,Task(..) + ,taskIsTarget ,taskLocation ,LocalPackage(..) ,BaseConfigOpts(..) @@ -35,6 +36,8 @@ module Stack.Types.Build ,ConfigCache(..) ,configCacheVC ,configureOpts + ,CachePkgSrc (..) + ,toCachePkgSrc ,isStackOpt ,wantedLocalPackages ,FileCacheInfo (..) @@ -44,7 +47,7 @@ module Stack.Types.Build where import Control.DeepSeq -import Control.Exception +import Control.Monad.IO.Unlift import Data.Binary (Binary) import Data.Binary.Tagged (HasSemanticVersion, HasStructuralInfo) @@ -80,7 +83,7 @@ import Path.Extra (toFilePathNoTrailingSep) import Paths_stack as Meta import Prelude import Stack.Constants -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Types.BuildPlan (PackageLocationIndex) import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config @@ -99,8 +102,8 @@ import System.Process.Log (showProcessArgDebug) data StackBuildException = Couldn'tFindPkgId PackageName | CompilerVersionMismatch - (Maybe (CompilerVersion, Arch)) -- found - (CompilerVersion, Arch) -- expected + (Maybe (CompilerVersion 'CVActual, Arch)) -- found + (CompilerVersion 'CVWanted, Arch) -- expected GHCVariant -- expected CompilerBuild -- expected VersionCheck @@ -129,7 +132,6 @@ data StackBuildException | NoSetupHsFound (Path Abs Dir) | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] - | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] | SolverGiveUp String | SolverMissingCabalInstall | SomeTargetsNotBuildable [(PackageName, NamedComponent)] @@ -301,15 +303,6 @@ instance Show StackBuildException where $ "The following errors occurred while parsing the build targets:" : map (("- " ++) . T.unpack) errs - show (DuplicateLocalPackageNames pairs) = concat - $ "The same package name is used in multiple local packages\n" - : map go pairs - where - go (name, dirs) = unlines - $ "" - : (packageNameString name ++ " used in:") - : map goDir dirs - goDir dir = "- " ++ toFilePath dir show (SolverGiveUp msg) = concat [ "\nSolver could not resolve package dependencies.\n" , "You can try the following:\n" @@ -393,13 +386,23 @@ data ConfigCache = ConfigCache -- is a convenient way to force compilation when the components change. , configCacheHaddock :: !Bool -- ^ Are haddocks to be built? + , configCachePkgSrc :: !CachePkgSrc } deriving (Generic, Eq, Show, Data, Typeable) instance Store ConfigCache instance NFData ConfigCache +data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath + deriving (Generic, Eq, Show, Data, Typeable) +instance Store CachePkgSrc +instance NFData CachePkgSrc + +toCachePkgSrc :: PackageSource -> CachePkgSrc +toCachePkgSrc (PSLocal lp) = CacheSrcLocal (toFilePath (lpDir lp)) +toCachePkgSrc PSUpstream{} = CacheSrcUpstream + configCacheVC :: VersionConfig ConfigCache -configCacheVC = storeVersionConfig "config-v1" "NMEzMXpksE1h7STRzlQ2f6Glkjo=" +configCacheVC = storeVersionConfig "config-v3" "z7N_NxX7Gbz41Gi9AGEa1zoLE-4=" -- | A task to perform when building data Task = Task @@ -412,6 +415,7 @@ data Task = Task -- ^ GhcPkgIds of already-installed dependencies , taskAllInOne :: !Bool -- ^ indicates that the package can be built in one step + , taskCachePkgSrc :: !CachePkgSrc } deriving Show @@ -433,9 +437,15 @@ instance Show TaskConfigOpts where -- | The type of a task, either building local code or something from the -- package index (upstream) data TaskType = TTLocal LocalPackage - | TTUpstream Package InstallLocation (Maybe GitSHA1) + | TTUpstream Package InstallLocation (PackageLocationIndex FilePath) -- FIXME major overhaul for PackageLocation? deriving Show +taskIsTarget :: Task -> Bool +taskIsTarget t = + case taskType t of + TTLocal lp -> lpWanted lp + _ -> False + taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index a5be367676..63a427f298 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -1,484 +1,348 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} - -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} -- | Shared types for various stackage packages. module Stack.Types.BuildPlan ( -- * Types - BuildPlan (..) - , PackagePlan (..) - , PackageConstraints (..) - , TestState (..) - , SystemInfo (..) - , Maintainer (..) + SnapshotDef (..) + , sdRawPathName + , PackageLocation (..) + , PackageLocationIndex (..) + , RepoType (..) + , Repo (..) , ExeName (..) - , SimpleDesc (..) - , Snapshots (..) - , DepInfo (..) - , Component (..) - , SnapName (..) - , MiniBuildPlan (..) - , miniBuildPlanVC - , MiniPackageInfo (..) - , CabalFileInfo (..) - , GitSHA1 (..) - , renderSnapName - , parseSnapName - , SnapshotHash (..) - , trimmedSnapshotHash + , LoadedSnapshot (..) + , loadedSnapshotVC + , LoadedPackageInfo (..) , ModuleName (..) + , fromCabalModuleName , ModuleInfo (..) , moduleInfoVC + , setCompilerVersion + , sdWantedCompilerVersion ) where import Control.Applicative -import Control.Arrow ((&&&)) import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) -import Data.Aeson (FromJSON (..), FromJSONKey(..), ToJSON (..), ToJSONKey (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) +import Data.Aeson (ToJSON (..), FromJSON (..), withText, object, (.=)) +import Data.Aeson.Extended (WithJSONWarnings (..), (..:), (..:?), withObjectWarnings, noJSONWarnings, (..!=)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Data -import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) import Data.Monoid import Data.Set (Set) +import qualified Data.Set as Set import Data.Store (Store) import Data.Store.Version import Data.Store.VersionTagged -import Data.String (IsString, fromString) -import Data.Text (Text, pack, unpack) +import Data.String (IsString) +import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Read (decimal) -import Data.Time (Day) -import qualified Data.Traversable as T -import Data.Vector (Vector) -import Distribution.System (Arch, OS (..)) -import qualified Distribution.Text as DT +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Distribution.ModuleName as C import qualified Distribution.Version as C import GHC.Generics (Generic) +import Network.HTTP.Client (parseRequest) import Prelude -- Fix AMP warning -import Safe (readMay) import Stack.Types.Compiler import Stack.Types.FlagName +import Stack.Types.GhcPkgId +import Stack.Types.PackageIdentifier import Stack.Types.PackageName +import Stack.Types.Resolver import Stack.Types.Version +import Stack.Types.VersionIntervals --- | The name of an LTS Haskell or Stackage Nightly snapshot. -data SnapName - = LTS !Int !Int - | Nightly !Day - deriving (Show, Eq, Ord) - -data BuildPlan = BuildPlan - { bpSystemInfo :: SystemInfo - , bpTools :: Vector (PackageName, Version) - , bpPackages :: Map PackageName PackagePlan - , bpGithubUsers :: Map Text (Set Text) - } - deriving (Show, Eq) - -instance ToJSON BuildPlan where - toJSON BuildPlan {..} = object - [ "system-info" .= bpSystemInfo - , "tools" .= fmap goTool bpTools - , "packages" .= bpPackages - , "github-users" .= bpGithubUsers - ] - where - goTool (k, v) = object - [ "name" .= k - , "version" .= v - ] -instance FromJSON BuildPlan where - parseJSON = withObject "BuildPlan" $ \o -> do - bpSystemInfo <- o .: "system-info" - bpTools <- o .: "tools" >>= T.mapM goTool - bpPackages <- o .: "packages" - bpGithubUsers <- o .:? "github-users" .!= mempty - return BuildPlan {..} - where - goTool = withObject "Tool" $ \o -> (,) - <$> o .: "name" - <*> o .: "version" - -data PackagePlan = PackagePlan - { ppVersion :: Version - , ppCabalFileInfo :: Maybe CabalFileInfo - , ppGithubPings :: Set Text - , ppUsers :: Set PackageName - , ppConstraints :: PackageConstraints - , ppDesc :: SimpleDesc +-- | A definition of a snapshot. This could be a Stackage snapshot or +-- something custom. It does not include information on the global +-- package database, this is added later. +-- +-- It may seem more logic to attach flags, options, etc, directly with +-- the desired package. However, this isn't possible yet: our +-- definition may contain tarballs or Git repos, and we don't actually +-- know the package names contained there. Therefore, we capture all +-- of this additional information by package name, and later in the +-- snapshot load step we will resolve the contents of tarballs and +-- repos, figure out package names, and assigned values appropriately. +data SnapshotDef = SnapshotDef + { sdParent :: !(Either (CompilerVersion 'CVWanted) SnapshotDef) + -- ^ The snapshot to extend from. This is either a specific + -- compiler, or a @SnapshotDef@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + , sdResolver :: !LoadedResolver + -- ^ The resolver that provides this definition. + , sdResolverName :: !Text + -- ^ A user-friendly way of referring to this resolver. + , sdLocations :: ![PackageLocationIndex [FilePath]] + -- ^ Where to grab all of the packages from. + , sdDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + , sdFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + , sdHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent snapshot. + , sdGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + , sdGlobalHints :: !(Map PackageName (Maybe Version)) + -- ^ Hints about which packages are available globally. When + -- actually building code, we trust the package database provided + -- by GHC itself, since it may be different based on platform or + -- GHC install. However, when we want to check the compatibility + -- of a snapshot with some codebase without installing GHC (e.g., + -- during stack init), we would use this field. } deriving (Show, Eq) -instance ToJSON PackagePlan where - toJSON PackagePlan {..} = object - $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo - [ "version" .= ppVersion - , "github-pings" .= ppGithubPings - , "users" .= ppUsers - , "constraints" .= ppConstraints - , "description" .= ppDesc - ] -instance FromJSON PackagePlan where - parseJSON = withObject "PackageBuild" $ \o -> do - ppVersion <- o .: "version" - ppCabalFileInfo <- o .:? "cabal-file-info" - ppGithubPings <- o .:? "github-pings" .!= mempty - ppUsers <- o .:? "users" .!= mempty - ppConstraints <- o .: "constraints" - ppDesc <- o .: "description" - return PackagePlan {..} - --- | Information on the contents of a cabal file -data CabalFileInfo = CabalFileInfo - { cfiSize :: !Int - -- ^ File size in bytes - , cfiHashes :: !(Map.Map Text Text) - -- ^ Various hashes of the file contents - } - deriving (Show, Eq, Generic) -instance ToJSON CabalFileInfo where - toJSON CabalFileInfo {..} = object - [ "size" .= cfiSize - , "hashes" .= cfiHashes - ] -instance FromJSON CabalFileInfo where - parseJSON = withObject "CabalFileInfo" $ \o -> do - cfiSize <- o .: "size" - cfiHashes <- o .: "hashes" - return CabalFileInfo {..} - -display :: DT.Text a => a -> Text -display = fromString . DT.display - -simpleParse :: (MonadThrow m, DT.Text a, Typeable a) => Text -> m a -simpleParse orig = withTypeRep $ \rep -> - case DT.simpleParse str of - Nothing -> throwM (ParseFailedException rep (pack str)) - Just v -> return v +-- | A relative file path including a unique string for the given +-- snapshot. +sdRawPathName :: SnapshotDef -> String +sdRawPathName sd = + T.unpack $ go $ sdResolver sd where - str = unpack orig - - withTypeRep :: Typeable a => (TypeRep -> m a) -> m a - withTypeRep f = - res - where - res = f (typeOf (unwrap res)) - - unwrap :: m a -> a - unwrap _ = error "unwrap" - -data BuildPlanTypesException - = ParseSnapNameException Text - | ParseFailedException TypeRep Text - deriving Typeable -instance Exception BuildPlanTypesException -instance Show BuildPlanTypesException where - show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t - show (ParseFailedException rep t) = - "Unable to parse " ++ show t ++ " as " ++ show rep + go (ResolverSnapshot name) = renderSnapName name + go (ResolverCompiler version) = compilerVersionText version + go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> decodeUtf8 (trimmedSnapshotHash hash) + +-- | Modify the wanted compiler version in this snapshot. This is used +-- when overriding via the `compiler` value in a custom snapshot or +-- stack.yaml file. We do _not_ need to modify the snapshot's hash for +-- this: all binary caches of a snapshot are stored in a filepath that +-- encodes the actual compiler version in addition to the +-- hash. Therefore, modifications here will not lead to any invalid +-- data. +setCompilerVersion :: CompilerVersion 'CVWanted -> SnapshotDef -> SnapshotDef +setCompilerVersion cv = + go + where + go sd = + case sdParent sd of + Left _ -> sd { sdParent = Left cv } + Right sd' -> sd { sdParent = Right $ go sd' } -data PackageConstraints = PackageConstraints - { pcVersionRange :: VersionRange - , pcMaintainer :: Maybe Maintainer - , pcTests :: TestState - , pcHaddocks :: TestState - , pcBuildBenchmarks :: Bool - , pcFlagOverrides :: Map FlagName Bool - , pcEnableLibProfile :: Bool - , pcHide :: Bool +-- | Where to get the contents of a package (including cabal file +-- revisions) from. +-- +-- A GADT may be more logical than the index parameter, but this plays +-- more nicely with Generic deriving. +data PackageLocation subdirs + = PLFilePath !FilePath + -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse + -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@. + | PLHttp !Text !subdirs + -- ^ URL + | PLRepo !(Repo subdirs) + -- ^ Stored in a source control repository + deriving (Generic, Show, Eq, Data, Typeable, Functor) +instance (Store a) => Store (PackageLocation a) +instance (NFData a) => NFData (PackageLocation a) + +-- | Add in the possibility of getting packages from the index +-- (including cabal file revisions). We have special handling of this +-- case in many places in the codebase, and therefore represent it +-- with a separate data type from 'PackageLocation'. +data PackageLocationIndex subdirs + = PLIndex !PackageIdentifierRevision + -- ^ Grab the package from the package index with the given + -- version and (optional) cabal file info to specify the correct + -- revision. + | PLOther !(PackageLocation subdirs) + deriving (Generic, Show, Eq, Data, Typeable, Functor) +instance (Store a) => Store (PackageLocationIndex a) +instance (NFData a) => NFData (PackageLocationIndex a) + +-- | The type of a source control repository. +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Data, Typeable) +instance Store RepoType +instance NFData RepoType + +-- | Information on packages stored in a source control repository. +data Repo subdirs = Repo + { repoUrl :: !Text + , repoCommit :: !Text + , repoType :: !RepoType + , repoSubdirs :: !subdirs } - deriving (Show, Eq) -instance ToJSON PackageConstraints where - toJSON PackageConstraints {..} = object $ addMaintainer - [ "version-range" .= display pcVersionRange - , "tests" .= pcTests - , "haddocks" .= pcHaddocks - , "build-benchmarks" .= pcBuildBenchmarks - , "flags" .= pcFlagOverrides - , "library-profiling" .= pcEnableLibProfile - , "hide" .= pcHide + deriving (Generic, Show, Eq, Data, Typeable, Functor) +instance Store a => Store (Repo a) +instance NFData a => NFData (Repo a) + +instance subdirs ~ [FilePath] => ToJSON (PackageLocationIndex subdirs) where + toJSON (PLIndex ident) = toJSON ident + toJSON (PLOther loc) = toJSON loc + +instance subdirs ~ [FilePath] => ToJSON (PackageLocation subdirs) where + toJSON (PLFilePath fp) = toJSON fp + toJSON (PLHttp t ["."]) = toJSON t + toJSON (PLHttp t subdirs) = object + [ "location" .= t + , "subdirs" .= subdirs + ] + toJSON (PLRepo (Repo url commit typ subdirs)) = object $ + (if null subdirs then id else (("subdirs" .= subdirs):)) + [ urlKey .= url + , "commit" .= commit ] where - addMaintainer = maybe id (\m -> (("maintainer" .= m):)) pcMaintainer -instance FromJSON PackageConstraints where - parseJSON = withObject "PackageConstraints" $ \o -> do - pcVersionRange <- (o .: "version-range") - >>= either (fail . show) return . simpleParse - pcTests <- o .: "tests" - pcHaddocks <- o .: "haddocks" - pcBuildBenchmarks <- o .: "build-benchmarks" - pcFlagOverrides <- o .: "flags" - pcMaintainer <- o .:? "maintainer" - pcEnableLibProfile <- fmap (fromMaybe True) (o .:? "library-profiling") - pcHide <- o .:? "hide" .!= False - return PackageConstraints {..} - -data TestState = ExpectSuccess - | ExpectFailure - | Don'tBuild -- ^ when the test suite will pull in things we don't want - deriving (Show, Eq, Ord, Bounded, Enum) - -testStateToText :: TestState -> Text -testStateToText ExpectSuccess = "expect-success" -testStateToText ExpectFailure = "expect-failure" -testStateToText Don'tBuild = "do-not-build" - -instance ToJSON TestState where - toJSON = toJSON . testStateToText -instance FromJSON TestState where - parseJSON = withText "TestState" $ \t -> - case HashMap.lookup t states of - Nothing -> fail $ "Invalid state: " ++ unpack t - Just v -> return v + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +instance subdirs ~ [FilePath] => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where + parseJSON v + = ((noJSONWarnings . PLIndex) <$> parseJSON v) + <|> (fmap PLOther <$> parseJSON v) + +instance subdirs ~ [FilePath] => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where + parseJSON v + = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) + <|> repo v + <|> httpSubdirs v where - states = HashMap.fromList - $ map (\x -> (testStateToText x, x)) [minBound..maxBound] - -data SystemInfo = SystemInfo - { siCompilerVersion :: CompilerVersion - , siOS :: OS - , siArch :: Arch - , siCorePackages :: Map PackageName Version - , siCoreExecutables :: Set ExeName - } - deriving (Show, Eq, Ord) -instance ToJSON SystemInfo where - toJSON SystemInfo {..} = object $ - (case siCompilerVersion of - GhcVersion version -> "ghc-version" .= version - _ -> "compiler-version" .= siCompilerVersion) : - [ "os" .= display siOS - , "arch" .= display siArch - , "core-packages" .= siCorePackages - , "core-executables" .= siCoreExecutables - ] -instance FromJSON SystemInfo where - parseJSON = withObject "SystemInfo" $ \o -> do - let helper name = (o .: name) >>= either (fail . show) return . simpleParse - ghcVersion <- o .:? "ghc-version" - compilerVersion <- o .:? "compiler-version" - siCompilerVersion <- - case (ghcVersion, compilerVersion) of - (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" - (Just ghc, _) -> return (GhcVersion ghc) - (_, Just compiler) -> return compiler - _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" - siOS <- helper "os" - siArch <- helper "arch" - siCorePackages <- o .: "core-packages" - siCoreExecutables <- o .: "core-executables" - return SystemInfo {..} - -newtype Maintainer = Maintainer { unMaintainer :: Text } - deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON, IsString) + file t = pure $ PLFilePath $ T.unpack t + http t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> return $ PLHttp t ["."] + + repo = withObjectWarnings "PLRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + repoSubdirs <- o ..:? "subdirs" ..!= [] + return $ PLRepo Repo {..} + + httpSubdirs = withObjectWarnings "PLHttp" $ \o -> do + url <- o ..: "location" + subdirs <- o ..: "subdirs" + case parseRequest $ T.unpack url of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack url + Right _ -> return $ PLHttp url subdirs -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } - deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable, ToJSON, ToJSONKey, FromJSONKey) -instance FromJSON ExeName where - parseJSON = withText "ExeName" $ return . ExeName + deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable) --- | A simplified package description that tracks: --- --- * Package dependencies +-- | A fully loaded snapshot combined , including information gleaned from the +-- global database and parsing cabal files. -- --- * Build tool dependencies +-- Invariant: a global package may not depend upon a snapshot package, +-- a snapshot may not depend upon a local or project, and all +-- dependencies must be satisfied. +data LoadedSnapshot = LoadedSnapshot + { lsCompilerVersion :: !(CompilerVersion 'CVActual) + , lsGlobals :: !(Map PackageName (LoadedPackageInfo GhcPkgId)) + , lsPackages :: !(Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))) + } + deriving (Generic, Show, Data, Eq, Typeable) +instance Store LoadedSnapshot +instance NFData LoadedSnapshot + +loadedSnapshotVC :: VersionConfig LoadedSnapshot +loadedSnapshotVC = storeVersionConfig "ls-v2" "xsmhHqmPKKcyHNzCLkKRGZ_StxE=" + +-- | Information on a single package for the 'LoadedSnapshot' which +-- can be installed. -- --- * Provided executables --- --- It has fully resolved all conditionals -data SimpleDesc = SimpleDesc - { sdPackages :: Map PackageName DepInfo - , sdTools :: Map ExeName DepInfo - , sdProvidedExes :: Set ExeName - , sdModules :: Set Text - -- ^ modules exported by the library +-- Note that much of the information below (such as the package +-- dependencies or exposed modules) can be conditional in the cabal +-- file, which means it will vary based on flags, arch, and OS. +data LoadedPackageInfo loc = LoadedPackageInfo + { lpiVersion :: !Version + -- ^ This /must/ match the version specified within 'rpiDef'. + , lpiLocation :: !loc + -- ^ Where to get the package from. This could be a few different + -- things: + -- + -- * For a global package, it will be the @GhcPkgId@. (If we end + -- up needing to rebuild this because we've changed a + -- dependency, we will take it from the package index with no + -- @CabalFileInfo@. + -- + -- * For a dependency, it will be a @PackageLocation@. + -- + -- * For a project package, it will be a @Path Abs Dir@. + , lpiFlags :: !(Map FlagName Bool) + -- ^ Flags to build this package with. + , lpiGhcOptions :: ![Text] + -- ^ GHC options to use when building this package. + , lpiPackageDeps :: !(Map PackageName VersionIntervals) + -- ^ All packages which must be built/copied/registered before + -- this package. + , lpiProvidedExes :: !(Set ExeName) + -- ^ The names of executables provided by this package, for + -- performing build tool lookups. + , lpiNeededExes :: !(Map ExeName VersionIntervals) + -- ^ Executables needed by this package. + , lpiExposedModules :: !(Set ModuleName) + -- ^ Modules exposed by this package's library + , lpiHide :: !Bool + -- ^ Should this package be hidden in the database. Affects the + -- script interpreter's module name import parser. } - deriving (Show, Eq) -instance Monoid SimpleDesc where - mempty = SimpleDesc mempty mempty mempty mempty - mappend (SimpleDesc a b c d) (SimpleDesc w x y z) = SimpleDesc - (Map.unionWith (<>) a w) - (Map.unionWith (<>) b x) - (c <> y) - (d <> z) -instance ToJSON SimpleDesc where - toJSON SimpleDesc {..} = object - [ "packages" .= sdPackages - , "tools" .= sdTools - , "provided-exes" .= sdProvidedExes - , "modules" .= sdModules - ] -instance FromJSON SimpleDesc where - parseJSON = withObject "SimpleDesc" $ \o -> do - sdPackages <- o .: "packages" - sdTools <- o .: "tools" - sdProvidedExes <- o .: "provided-exes" - sdModules <- o .: "modules" - return SimpleDesc {..} + deriving (Generic, Show, Eq, Data, Typeable, Functor) +instance Store a => Store (LoadedPackageInfo a) +instance NFData a => NFData (LoadedPackageInfo a) data DepInfo = DepInfo - { diComponents :: Set Component - , diRange :: VersionRange + { _diComponents :: !(Set Component) + , _diRange :: !VersionIntervals } - deriving (Show, Eq) + deriving (Generic, Show, Eq, Data, Typeable) +instance Store DepInfo +instance NFData DepInfo instance Monoid DepInfo where - mempty = DepInfo mempty C.anyVersion + mempty = DepInfo mempty (fromVersionRange C.anyVersion) DepInfo a x `mappend` DepInfo b y = DepInfo (mappend a b) - (C.intersectVersionRanges x y) -instance ToJSON DepInfo where - toJSON DepInfo {..} = object - [ "components" .= diComponents - , "range" .= display diRange - ] -instance FromJSON DepInfo where - parseJSON = withObject "DepInfo" $ \o -> do - diComponents <- o .: "components" - diRange <- o .: "range" >>= either (fail . show) return . simpleParse - return DepInfo {..} + (intersectVersionIntervals x y) data Component = CompLibrary | CompExecutable | CompTestSuite | CompBenchmark - deriving (Show, Read, Eq, Ord, Enum, Bounded) - -compToText :: Component -> Text -compToText CompLibrary = "library" -compToText CompExecutable = "executable" -compToText CompTestSuite = "test-suite" -compToText CompBenchmark = "benchmark" - -instance ToJSON Component where - toJSON = toJSON . compToText -instance FromJSON Component where - parseJSON = withText "Component" $ \t -> maybe - (fail $ "Invalid component: " ++ unpack t) - return - (HashMap.lookup t comps) - where - comps = HashMap.fromList $ map (compToText &&& id) [minBound..maxBound] - --- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@, --- @nightly-2015-03-05@. -renderSnapName :: SnapName -> Text -renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] -renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d - --- | Parse the short representation of a 'SnapName'. -parseSnapName :: MonadThrow m => Text -> m SnapName -parseSnapName t0 = - case lts <|> nightly of - Nothing -> throwM $ ParseSnapNameException t0 - Just sn -> return sn - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - return $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMay (T.unpack t1) - --- | Most recent Nightly and newest LTS version per major release. -data Snapshots = Snapshots - { snapshotsNightly :: !Day - , snapshotsLts :: !(IntMap Int) - } - deriving Show -instance FromJSON Snapshots where - parseJSON = withObject "Snapshots" $ \o -> Snapshots - <$> (o .: "nightly" >>= parseNightly) - <*> fmap IntMap.unions (mapM (parseLTS . snd) - $ filter (isLTS . fst) - $ HashMap.toList o) - where - parseNightly t = - case parseSnapName t of - Left e -> fail $ show e - Right (LTS _ _) -> fail "Unexpected LTS value" - Right (Nightly d) -> return d - - isLTS = ("lts-" `T.isPrefixOf`) - - parseLTS = withText "LTS" $ \t -> - case parseSnapName t of - Left e -> fail $ show e - Right (LTS x y) -> return $ IntMap.singleton x y - Right (Nightly _) -> fail "Unexpected nightly value" - --- | A simplified version of the 'BuildPlan' + cabal file. -data MiniBuildPlan = MiniBuildPlan - { mbpCompilerVersion :: !CompilerVersion - , mbpPackages :: !(Map PackageName MiniPackageInfo) - } - deriving (Generic, Show, Eq, Data, Typeable) -instance Store MiniBuildPlan -instance NFData MiniBuildPlan - -miniBuildPlanVC :: VersionConfig MiniBuildPlan -miniBuildPlanVC = storeVersionConfig "mbp-v2" "C8q73RrYq3plf9hDCapjWpnm_yc=" - --- | Information on a single package for the 'MiniBuildPlan'. -data MiniPackageInfo = MiniPackageInfo - { mpiVersion :: !Version - , mpiFlags :: !(Map FlagName Bool) - , mpiGhcOptions :: ![Text] - , mpiPackageDeps :: !(Set PackageName) - , mpiToolDeps :: !(Set Text) - -- ^ Due to ambiguity in Cabal, it is unclear whether this refers to the - -- executable name, the package name, or something else. We have to guess - -- based on what's available, which is why we store this is an unwrapped - -- 'Text'. - , mpiExes :: !(Set ExeName) - -- ^ Executables provided by this package - , mpiHasLibrary :: !Bool - -- ^ Is there a library present? - , mpiGitSHA1 :: !(Maybe GitSHA1) - -- ^ An optional SHA1 representation in hex format of the blob containing - -- the cabal file contents. Useful for grabbing the correct cabal file - -- revision directly from a Git repo - } - deriving (Generic, Show, Eq, Data, Typeable) -instance Store MiniPackageInfo -instance NFData MiniPackageInfo - -newtype GitSHA1 = GitSHA1 ByteString - 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 + deriving (Generic, Show, Eq, Ord, Data, Typeable, Enum, Bounded) +instance Store Component +instance NFData Component 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)) +fromCabalModuleName :: C.ModuleName -> ModuleName +fromCabalModuleName = ModuleName . encodeUtf8 . T.intercalate "." . map T.pack . C.components + +newtype ModuleInfo = ModuleInfo + { miModules :: Map ModuleName (Set PackageName) } deriving (Show, Eq, Ord, Generic, Typeable, Data) instance Store ModuleInfo instance NFData ModuleInfo +instance Monoid ModuleInfo where + mempty = ModuleInfo mempty + mappend (ModuleInfo x) (ModuleInfo y) = + ModuleInfo (Map.unionWith Set.union x y) + moduleInfoVC :: VersionConfig ModuleInfo -moduleInfoVC = storeVersionConfig "mi-v1" "zyCpzzGXA8fTeBmKEWLa_6kF2_s=" +moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s=" + +-- | Determined the desired compiler version for this 'SnapshotDef'. +sdWantedCompilerVersion :: SnapshotDef -> CompilerVersion 'CVWanted +sdWantedCompilerVersion = either id sdWantedCompilerVersion . sdParent diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs index e565910e9e..6c9520fa29 100644 --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} module Stack.Types.Compiler where @@ -20,6 +23,12 @@ data WhichCompiler | Ghcjs deriving (Show, Eq, Ord) +-- | Whether the compiler version given is the wanted version (what +-- the stack.yaml file, snapshot file, or --resolver argument +-- request), or the actual installed GHC. Depending on the matching +-- requirements, these values could be different. +data CVType = CVWanted | CVActual + -- | Specifies a compiler and its version number(s). -- -- Note that despite having this datatype, stack isn't in a hurry to @@ -28,26 +37,34 @@ data WhichCompiler -- NOTE: updating this will change its binary serialization. The -- version number in the 'BinarySchema' instance for 'MiniBuildPlan' -- should be updated. -data CompilerVersion +data CompilerVersion (cvType :: CVType) = GhcVersion {-# UNPACK #-} !Version | GhcjsVersion {-# UNPACK #-} !Version -- GHCJS version {-# UNPACK #-} !Version -- GHC version deriving (Generic, Show, Eq, Ord, Data, Typeable) -instance Store CompilerVersion -instance NFData CompilerVersion -instance ToJSON CompilerVersion where +instance Store (CompilerVersion a) +instance NFData (CompilerVersion a) +instance ToJSON (CompilerVersion a) where toJSON = toJSON . compilerVersionText -instance FromJSON CompilerVersion where +instance FromJSON (CompilerVersion a) where parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t) parseJSON _ = fail "Invalid CompilerVersion, must be String" -instance FromJSONKey CompilerVersion where +instance FromJSONKey (CompilerVersion a) where fromJSONKey = FromJSONKeyTextParser $ \k -> case parseCompilerVersion k of Nothing -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k Just parsed -> return parsed -parseCompilerVersion :: T.Text -> Maybe CompilerVersion +actualToWanted :: CompilerVersion 'CVActual -> CompilerVersion 'CVWanted +actualToWanted (GhcVersion x) = GhcVersion x +actualToWanted (GhcjsVersion x y) = GhcjsVersion x y + +wantedToActual :: CompilerVersion 'CVWanted -> CompilerVersion 'CVActual +wantedToActual (GhcVersion x) = GhcVersion x +wantedToActual (GhcjsVersion x y) = GhcjsVersion x y + +parseCompilerVersion :: T.Text -> Maybe (CompilerVersion a) parseCompilerVersion t | Just t' <- T.stripPrefix "ghc-" t , Just v <- parseVersionFromString $ T.unpack t' @@ -60,27 +77,27 @@ parseCompilerVersion t | otherwise = Nothing -compilerVersionText :: CompilerVersion -> T.Text +compilerVersionText :: CompilerVersion a -> T.Text compilerVersionText (GhcVersion vghc) = "ghc-" <> versionText vghc compilerVersionText (GhcjsVersion vghcjs vghc) = "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc -compilerVersionString :: CompilerVersion -> String +compilerVersionString :: CompilerVersion a -> String compilerVersionString = T.unpack . compilerVersionText -whichCompiler :: CompilerVersion -> WhichCompiler +whichCompiler :: CompilerVersion a -> WhichCompiler whichCompiler GhcVersion {} = Ghc whichCompiler GhcjsVersion {} = Ghcjs -isWantedCompiler :: VersionCheck -> CompilerVersion -> CompilerVersion -> Bool +isWantedCompiler :: VersionCheck -> CompilerVersion 'CVWanted -> CompilerVersion 'CVActual -> Bool isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = checkVersion check wanted actual isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = checkVersion check wanted actual && checkVersion check wantedGhc actualGhc isWantedCompiler _ _ _ = False -getGhcVersion :: CompilerVersion -> Version +getGhcVersion :: CompilerVersion a -> Version getGhcVersion (GhcVersion v) = v getGhcVersion (GhcjsVersion _ v) = v diff --git a/src/Stack/Types/CompilerBuild.hs b/src/Stack/Types/CompilerBuild.hs index 953874a305..9ffb60e8c3 100644 --- a/src/Stack/Types/CompilerBuild.hs +++ b/src/Stack/Types/CompilerBuild.hs @@ -5,7 +5,7 @@ module Stack.Types.CompilerBuild ,parseCompilerBuild ) where -import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Unlift import Data.Aeson.Extended (FromJSON, parseJSON, withText) import Data.Text as T diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 92419c1618..76cba20cd4 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -36,6 +36,9 @@ module Stack.Types.Config ,getMinimalEnvOverride -- ** BuildConfig & HasBuildConfig ,BuildConfig(..) + ,LocalPackages(..) + ,LocalPackageView(..) + ,NamedComponent(..) ,stackYamlL ,projectRootL ,HasBuildConfig(..) @@ -76,11 +79,6 @@ module Stack.Types.Config ,defaultLogLevel -- ** LoadConfig ,LoadConfig(..) - -- ** PackageEntry & PackageLocation - ,PackageEntry(..) - ,TreatLikeExtraDep - ,PackageLocation(..) - ,RemotePackageType(..) -- ** PackageIndex, IndexName & IndexLocation -- Re-exports @@ -101,23 +99,21 @@ module Stack.Types.Config ,parseProjectAndConfigMonoid -- ** PvpBounds ,PvpBounds(..) + ,PvpBoundsType(..) ,parsePvpBounds -- ** ColorWhen ,ColorWhen(..) ,readColorWhen -- ** SCM ,SCM(..) - -- ** CustomSnapshot - ,CustomSnapshot(..) -- ** GhcOptions ,GhcOptions(..) ,ghcOptionsFor - -- ** PackageFlags - ,PackageFlags(..) -- * Paths ,bindirSuffix ,configInstalledCache - ,configMiniBuildPlanCache + ,configLoadedSnapshotCache + ,GlobalInfoSource(..) ,getProjectWorkDir ,docDirSuffix ,flagCacheLocal @@ -170,6 +166,8 @@ module Stack.Types.Config ,configUrlsL ,cabalVersionL ,whichCompilerL + ,envOverrideL + ,loadedSnapshotL -- * Lens reexport ,view ,to @@ -177,12 +175,10 @@ module Stack.Types.Config import Control.Applicative import Control.Arrow ((&&&)) -import Control.Exception -import Control.Monad (liftM, mzero, join) -import Control.Monad.Catch (MonadThrow, MonadMask) +import Control.Monad (liftM, join) +import Control.Monad.IO.Unlift import Control.Monad.Logger (LogLevel(..), MonadLoggerIO) -import Control.Monad.Reader (MonadReader, MonadIO, liftIO) -import Control.Monad.Trans.Control +import Control.Monad.Reader (MonadReader) import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, object, (.=), (..:), (..:?), (..!=), Value(Bool, String), @@ -210,6 +206,8 @@ import Data.Text.Encoding (encodeUtf8) import Data.Typeable import Data.Yaml (ParseException) import qualified Data.Yaml as Yaml +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.ParseUtils (PError) import Distribution.System (Platform) import qualified Distribution.Text import Distribution.Version (anyVersion) @@ -217,13 +215,12 @@ 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 (GitSHA1, MiniBuildPlan(..), SnapName, renderSnapName) +import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker @@ -361,7 +358,7 @@ data Config = -- ^ Allow users other than the stack root owner to use the stack -- installation. ,configPackageCaches :: !(IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache), - HashMap GitSHA1 (PackageIndex, OffsetSize)))) + HashMap CabalHash (PackageIndex, OffsetSize)))) -- ^ In memory cache of hackage index. ,configDumpLogs :: !DumpLogs -- ^ Dump logs of local non-dependencies when doing a build. @@ -371,6 +368,8 @@ data Config = ,configAllowLocals :: !Bool -- ^ Are we allowed to build local packages? The script -- command disallows this. + ,configSaveHackageCreds :: !Bool + -- ^ Should we save Hackage credentials to a file? } -- | Which packages do ghc-options on the command line apply to? @@ -455,7 +454,7 @@ data GlobalOpts = GlobalOpts , globalTimeInLog :: !Bool -- ^ Whether to include timings in logs. , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override - , globalCompiler :: !(Maybe CompilerVersion) -- ^ Compiler override + , globalCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors , globalStackYaml :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml @@ -476,7 +475,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidTimeInLog :: !(First Bool) -- ^ Whether to include timings in logs. , globalMonoidConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalMonoidResolver :: !(First AbstractResolver) -- ^ Resolver override - , globalMonoidCompiler :: !(First CompilerVersion) -- ^ Compiler override + , globalMonoidCompiler :: !(First (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? , globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml @@ -509,16 +508,13 @@ readColorWhen = do -- 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 + , bcSnapshotDef :: !SnapshotDef -- ^ Build plan wanted for this build , bcGHCVariant :: !GHCVariant -- ^ The variant of GHC used to select a GHC bindist. - , bcPackageEntries :: ![PackageEntry] + , bcPackages :: ![PackageLocation [FilePath]] -- ^ Local packages - , bcExtraDeps :: !(Map PackageName Version) + , bcDependencies :: ![PackageLocationIndex [FilePath]] -- ^ Extra dependencies specified in configuration. -- -- These dependencies will not be installed to a shared location, and @@ -533,7 +529,7 @@ data BuildConfig = BuildConfig -- -- FIXME MSS 2016-12-08: is the above comment still true? projectRootL -- is defined in terms of bcStackYaml - , bcFlags :: !PackageFlags + , bcFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Per-package flag overrides , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful @@ -557,20 +553,45 @@ data EnvConfig = EnvConfig -- Note that this is not necessarily the same version as the one that stack -- depends on as a library and which is displayed when running -- @stack list-dependencies | grep Cabal@ in the stack project. - ,envConfigCompilerVersion :: !CompilerVersion + ,envConfigCompilerVersion :: !(CompilerVersion 'CVActual) -- ^ 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))) + ,envConfigPackagesRef :: !(IORef (Maybe LocalPackages)) -- ^ Cache for 'getLocalPackages'. + ,envConfigLoadedSnapshot :: !LoadedSnapshot + -- ^ The fully resolved snapshot information. } +data LocalPackages = LocalPackages + { lpProject :: !(Map PackageName LocalPackageView) + , lpDependencies :: !(Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath)) + } + +-- | A view of a local package needed for resolving components +data LocalPackageView = LocalPackageView + { lpvVersion :: !Version + , lpvRoot :: !(Path Abs Dir) + , lpvCabalFP :: !(Path Abs File) + , lpvComponents :: !(Set NamedComponent) + , lpvGPD :: !GenericPackageDescription + , lpvLoc :: !(PackageLocation FilePath) + } + +-- | A single, fully resolved component of a package +data NamedComponent + = CLib + | CExe !Text + | CTest !Text + | CBench !Text + deriving (Show, Eq, Ord) + -- | Value returned by 'Stack.Config.loadConfig'. data LoadConfig m = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration. - , lcLoadBuildConfig :: !(Maybe CompilerVersion -> m BuildConfig) + , lcLoadBuildConfig :: !(Maybe (CompilerVersion 'CVWanted) -> m BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. @@ -578,7 +599,7 @@ data LoadConfig m = LoadConfig data PackageEntry = PackageEntry { peExtraDepMaybe :: !(Maybe TreatLikeExtraDep) - , peLocation :: !PackageLocation + , peLocation :: !(PackageLocation [FilePath]) , peSubdirs :: ![FilePath] } deriving Show @@ -619,81 +640,51 @@ instance FromJSON (WithJSONWarnings PackageEntry) where <*> jsonSubWarnings (o ..: "location") <*> o ..:? "subdirs" ..!= []) v -data PackageLocation - = PLFilePath FilePath - -- ^ Note that we use @FilePath@ and not @Path@s. The goal is: first parse - -- the value raw, and then use @canonicalizePath@ and @parseAbsDir@. - | PLRemote Text RemotePackageType - -- ^ URL and further details - deriving Show - -data RemotePackageType - = RPTHttp - | RPTGit Text -- ^ Commit - | RPTHg Text -- ^ Commit - deriving Show - -instance ToJSON PackageLocation where - toJSON (PLFilePath fp) = toJSON fp - toJSON (PLRemote t RPTHttp) = toJSON t - toJSON (PLRemote x (RPTGit y)) = object [("git", toJSON x), ("commit", toJSON y)] - toJSON (PLRemote x (RPTHg y)) = object [( "hg", toJSON x), ("commit", toJSON y)] - -instance FromJSON (WithJSONWarnings PackageLocation) where - parseJSON v - = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) - <|> git v - <|> hg v - where - file t = pure $ PLFilePath $ T.unpack t - http t = - case parseRequest $ T.unpack t of - Left _ -> mzero - Right _ -> return $ PLRemote t RPTHttp - - git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote - <$> o ..: "git" - <*> (RPTGit <$> o ..: "commit") - hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote - <$> o ..: "hg" - <*> (RPTHg <$> o ..: "commit") - -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information. data Project = Project { projectUserMsg :: !(Maybe String) -- ^ A warning message to display to the user when the auto generated -- config may have issues. - , projectPackages :: ![PackageEntry] - -- ^ Components of the package list - , projectExtraDeps :: !(Map PackageName Version) - -- ^ Components of the package list referring to package/version combos, - -- see: https://github.com/fpco/stack/issues/41 - , projectFlags :: !PackageFlags - -- ^ Per-package flag overrides + , projectPackages :: ![PackageLocation [FilePath]] + -- ^ Packages which are actually part of the project (as opposed + -- to dependencies). + -- + -- /NOTE/ Stack has always allowed these packages to be any kind + -- of package location, but in reality only @PLFilePath@ really + -- makes sense. We could consider replacing @[PackageLocation]@ + -- with @[FilePath]@ to properly enforce this idea, though it will + -- slightly break backwards compatibility if someone really did + -- want to treat such things as non-deps. + , projectDependencies :: ![PackageLocationIndex [FilePath]] + -- ^ Dependencies defined within the stack.yaml file, to be + -- applied on top of the snapshot. + , projectFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flags to be applied on top of the snapshot flags. , projectResolver :: !Resolver - -- ^ How we resolve which dependencies to use - , projectCompiler :: !(Maybe CompilerVersion) + -- ^ How we resolve which @SnapshotDef@ to use + , projectCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ When specified, overrides which compiler to use , projectExtraPackageDBs :: ![FilePath] } deriving Show instance ToJSON Project where - toJSON p = object $ - maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p) $ - maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p) - [ "packages" .= projectPackages p - , "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p) - , "flags" .= projectFlags p - , "resolver" .= projectResolver p - , "extra-package-dbs" .= projectExtraPackageDBs p + -- Expanding the constructor fully to ensure we don't miss any fields. + toJSON (Project userMsg packages extraDeps flags resolver compiler extraPackageDBs) = object $ + maybe id (\cv -> (("compiler" .= cv) :)) compiler $ + maybe id (\msg -> (("user-message" .= msg) :)) userMsg $ + (if null extraPackageDBs then id else (("extra-package-dbs" .= extraPackageDBs):)) $ + (if null extraDeps then id else (("extra-deps" .= extraDeps):)) $ + (if Map.null flags then id else (("flags" .= flags):)) + [ "packages" .= packages + , "resolver" .= resolver ] -- | Constraint synonym for constraints satisfied by a 'MiniConfig' -- environment. type StackMiniM r m = - ( MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m + ( MonadReader r m, MonadUnliftIO m, MonadLoggerIO m, MonadThrow m ) -- An uninterpreted representation of configuration options. @@ -784,6 +775,8 @@ data ConfigMonoid = -- installation. , configMonoidDumpLogs :: !(First DumpLogs) -- ^ See 'configDumpLogs' + , configMonoidSaveHackageCreds :: !(First Bool) + -- ^ See 'configSaveHackageCreds' } deriving (Show, Generic) @@ -855,6 +848,7 @@ parseConfigMonoidObject rootDir obj = do configMonoidDefaultTemplate <- First <$> obj ..:? configMonoidDefaultTemplateName configMonoidAllowDifferentUser <- First <$> obj ..:? configMonoidAllowDifferentUserName configMonoidDumpLogs <- First <$> obj ..:? configMonoidDumpLogsName + configMonoidSaveHackageCreds <- First <$> obj ..:? configMonoidSaveHackageCredsName return ConfigMonoid {..} where @@ -988,17 +982,19 @@ configMonoidAllowDifferentUserName = "allow-different-user" configMonoidDumpLogsName :: Text configMonoidDumpLogsName = "dump-logs" +configMonoidSaveHackageCredsName :: Text +configMonoidSaveHackageCredsName = "save-hackage-creds" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseCustomSnapshotException Text ParseException - | ParseResolverException Text | NoProjectConfigFound (Path Abs Dir) (Maybe Text) | UnexpectedArchiveContents [Path Abs Dir] [Path Abs File] | UnableToExtractArchive Text (Path Abs File) | BadStackVersionException VersionRange | NoMatchingSnapshot WhichSolverCmd (NonEmpty SnapName) - | forall l. ResolverMismatch WhichSolverCmd (ResolverThat's l) String - | ResolverPartial WhichSolverCmd Resolver String + | ResolverMismatch WhichSolverCmd !Text String -- Text == resolver name, sdName + | ResolverPartial WhichSolverCmd !Text String -- Text == resolver name, sdName | NoSuchDirectory FilePath | ParseGHCVariantException String | BadStackRoot (Path Abs Dir) @@ -1009,6 +1005,8 @@ data ConfigException | NixRequiresSystemGhc | NoResolverWhenUsingNoLocalConfig | InvalidResolverForNoLocalConfig String + | InvalidCabalFileInLocal !(PackageLocationIndex FilePath) !PError !ByteString + | DuplicateLocalPackageNames ![(PackageName, [PackageLocationIndex FilePath])] deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -1026,12 +1024,6 @@ instance Show ConfigException where -- FIXME: Link to docs about custom snapshots -- , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/" ] - show (ParseResolverException t) = concat - [ "Invalid resolver value: " - , T.unpack t - , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. " - , "See https://www.stackage.org/snapshots for a complete list." - ] show (NoProjectConfigFound dir mcmd) = concat [ "Unable to find a stack.yaml file in the current directory (" , toFilePath dir @@ -1067,7 +1059,7 @@ instance Show ConfigException where ] show (ResolverMismatch whichCmd resolver errDesc) = concat [ "Resolver '" - , T.unpack (resolverName resolver) + , T.unpack resolver , "' does not have a matching compiler to build some or all of your " , "package(s).\n" , errDesc @@ -1075,7 +1067,7 @@ instance Show ConfigException where ] show (ResolverPartial whichCmd resolver errDesc) = concat [ "Resolver '" - , T.unpack (resolverName resolver) + , T.unpack resolver , "' does not have all the packages to match your requirements.\n" , unlines $ fmap (" " <>) (lines errDesc) , showOptions whichCmd @@ -1129,6 +1121,21 @@ instance Show ConfigException where ] show NoResolverWhenUsingNoLocalConfig = "When using the script command, you must provide a resolver argument" show (InvalidResolverForNoLocalConfig ar) = "The script command requires a specific resolver, you provided " ++ ar + show (InvalidCabalFileInLocal loc err _) = concat + [ "Unable to parse cabal file from " + , show loc + , ": " + , show err + ] + show (DuplicateLocalPackageNames pairs) = concat + $ "The same package name is used in multiple local packages\n" + : map go pairs + where + go (name, dirs) = unlines + $ "" + : (packageNameString name ++ " used in:") + : map goLoc dirs + goLoc loc = "- " ++ show loc instance Exception ConfigException showOptions :: WhichSolverCmd -> SuggestSolver -> String @@ -1258,9 +1265,9 @@ platformSnapAndCompilerRel :: (MonadReader env m, HasEnvConfig env, MonadThrow m) => m (Path Rel Dir) platformSnapAndCompilerRel = do - resolver' <- view loadedResolverL + sd <- view snapshotDefL platform <- platformGhcRelDir - name <- parseRelDir $ T.unpack $ resolverDirName resolver' + name <- parseRelDir $ sdRawPathName sd ghc <- compilerVersionDir useShaPathOnWindows (platform name ghc) @@ -1335,16 +1342,30 @@ flagCacheLocal = do root <- installationRootLocal return $ root $(mkRelDir "flag-cache") --- | Where to store mini build plan caches -configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) - => SnapName - -> m (Path Abs File) -configMiniBuildPlanCache name = do +-- | Where to store 'LoadedSnapshot' caches +configLoadedSnapshotCache + :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) + => SnapshotDef + -> GlobalInfoSource + -> m (Path Abs File) +configLoadedSnapshotCache sd gis = do root <- view stackRootL platform <- platformGhcVerOnlyRelDir - file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" + file <- parseRelFile $ sdRawPathName sd ++ ".cache" + gis' <- parseRelDir $ + case gis of + GISSnapshotHints -> "__snapshot_hints__" + GISCompiler cv -> compilerVersionString cv -- Yes, cached plans differ based on platform - return (root $(mkRelDir "build-plan-cache") platform file) + return (root $(mkRelDir "loaded-snapshot-cache") platform gis' file) + +-- | Where do we get information on global packages for loading up a +-- 'LoadedSnapshot'? +data GlobalInfoSource + = GISSnapshotHints + -- ^ Accept the hints in the snapshot definition + | GISCompiler (CompilerVersion 'CVActual) + -- ^ Look up the actual information in the installed compiler -- | Suffix applied to an installation root to get the bin dir bindirSuffix :: Path Rel Dir @@ -1409,45 +1430,58 @@ parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWar parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] - extraDeps' <- o ..:? "extra-deps" ..!= [] - extraDeps <- - case partitionEithers $ goDeps extraDeps' of - ([], x) -> return $ Map.fromList x - (errs, _) -> fail $ unlines errs - + extraDeps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags <- o ..:? "flags" ..!= mempty - resolver <- jsonSubWarnings (o ..: "resolver") + + -- Convert the packages/extra-deps/flags approach we use in + -- the stack.yaml into the internal representation. + (packages, deps) <- convert dirs extraDeps + + resolver <- (o ..: "resolver") + >>= either (fail . show) return + . parseCustomLocation (Just rootDir) compiler <- o ..:? "compiler" msg <- o ..:? "user-message" config <- parseConfigMonoidObject rootDir o extraPackageDBs <- o ..:? "extra-package-dbs" ..!= [] let project = Project { projectUserMsg = msg - , projectPackages = dirs - , projectExtraDeps = extraDeps - , projectFlags = flags , projectResolver = resolver , projectCompiler = compiler , projectExtraPackageDBs = extraPackageDBs + , projectPackages = packages + , projectDependencies = deps + , projectFlags = flags } return $ ProjectAndConfigMonoid project config where - goDeps = - map toSingle . Map.toList . Map.unionsWith Set.union . map toMap + convert :: Monad m + => [PackageEntry] + -> [PackageLocationIndex [FilePath]] -- extra-deps + -> m ( [PackageLocation [FilePath]] -- project + , [PackageLocationIndex [FilePath]] -- dependencies + ) + convert entries extraDeps = do + projLocs <- mapM goEntry entries + return $ partitionEithers $ concat projLocs ++ map Right extraDeps where - toMap i = Map.singleton - (packageIdentifierName i) - (Set.singleton (packageIdentifierVersion i)) - - toSingle (k, s) = - case Set.toList s of - [x] -> Right (k, x) - xs -> Left $ concat - [ "Multiple versions for package " - , packageNameString k - , ": " - , unwords $ map versionString xs - ] + goEntry (PackageEntry Nothing pl@(PLFilePath _) subdirs) = goEntry' False pl subdirs + goEntry (PackageEntry Nothing pl _) = fail $ concat + [ "Refusing to implicitly treat package location as an extra-dep:\n" + , show pl + , "\nRecommendation: either move to 'extra-deps' or set 'extra-dep: true'." + ] + goEntry (PackageEntry (Just extraDep) pl subdirs) = goEntry' extraDep pl subdirs + + goEntry' extraDep pl subdirs = do + pl' <- addSubdirs pl subdirs + return $ map (if extraDep then Right . PLOther else Left) pl' + + addSubdirs pl [] = return [pl] + addSubdirs (PLRepo repo) subdirs = return [PLRepo repo { repoSubdirs = subdirs ++ repoSubdirs repo }] + addSubdirs (PLFilePath fp) subdirs = return $ map (\subdir -> PLFilePath $ fp FilePath. subdir) subdirs + addSubdirs pl (_:_) = fail $ + "Cannot set subdirs on package location: " ++ show pl -- | A PackageEntry for the current directory, used as a default packageEntryCurrDir :: PackageEntry @@ -1579,7 +1613,7 @@ data SetupInfo = SetupInfo , siSevenzDll :: Maybe DownloadInfo , siMsys2 :: Map Text VersionedDownloadInfo , siGHCs :: Map Text (Map Version GHCDownloadInfo) - , siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo) + , siGHCJSs :: Map Text (Map (CompilerVersion 'CVActual) DownloadInfo) , siStack :: Map Text (Map Version DownloadInfo) } deriving Show @@ -1632,29 +1666,44 @@ instance FromJSON (WithJSONWarnings SetupInfoLocation) where return $ WithJSONWarnings (SetupInfoInline si) w -- | How PVP bounds should be added to .cabal files -data PvpBounds +data PvpBoundsType = PvpBoundsNone | PvpBoundsUpper | PvpBoundsLower | PvpBoundsBoth deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded) -pvpBoundsText :: PvpBounds -> Text +data PvpBounds = PvpBounds + { pbType :: !PvpBoundsType + , pbAsRevision :: !Bool + } + deriving (Show, Read, Eq, Typeable, Ord) + +pvpBoundsText :: PvpBoundsType -> Text pvpBoundsText PvpBoundsNone = "none" pvpBoundsText PvpBoundsUpper = "upper" pvpBoundsText PvpBoundsLower = "lower" pvpBoundsText PvpBoundsBoth = "both" parsePvpBounds :: Text -> Either String PvpBounds -parsePvpBounds t = - case Map.lookup t m of - Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t - Just x -> Right x +parsePvpBounds t = maybe err Right $ do + (t', asRevision) <- + case T.break (== '-') t of + (x, "") -> Just (x, False) + (x, "-revision") -> Just (x, True) + _ -> Nothing + x <- Map.lookup t' m + Just PvpBounds + { pbType = x + , pbAsRevision = asRevision + } where m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound] + err = Left $ "Invalid PVP bounds: " ++ T.unpack t instance ToJSON PvpBounds where - toJSON = toJSON . pvpBoundsText + toJSON (PvpBounds typ asRevision) = + toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else "")) instance FromJSON PvpBounds where parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds) @@ -1686,29 +1735,6 @@ data DockerUser = DockerUser , duUmask :: FileMode -- ^ File creation mask } } deriving (Read,Show) --- TODO: See section of --- https://github.com/commercialhaskell/stack/issues/1265 about --- rationalizing the config. It would also be nice to share more code. --- For now it's more convenient just to extend this type. However, it's --- unpleasant that it has overlap with both 'Project' and 'Config'. -data CustomSnapshot = CustomSnapshot - { csCompilerVersion :: !(Maybe CompilerVersion) - , csPackages :: !(Set PackageIdentifier) - , csDropPackages :: !(Set PackageName) - , csFlags :: !PackageFlags - , csGhcOptions :: !GhcOptions - } - -instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where - parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,) - <$> (CustomSnapshot - <$> o ..:? "compiler" - <*> o ..:? "packages" ..!= mempty - <*> o ..:? "drop-packages" ..!= mempty - <*> o ..:? "flags" ..!= mempty - <*> o ..:? configMonoidGhcOptionsName ..!= mempty) - <*> jsonSubWarningsT (o ..:? "resolver") - newtype GhcOptions = GhcOptions { unGhcOptions :: Map (Maybe PackageName) [Text] } deriving Show @@ -1747,21 +1773,6 @@ ghcOptionsFor name (GhcOptions mp) = M.findWithDefault [] Nothing mp ++ M.findWithDefault [] (Just name) mp -newtype PackageFlags = PackageFlags - { unPackageFlags :: Map PackageName (Map FlagName Bool) } - deriving Show - -instance FromJSON PackageFlags where - parseJSON val = PackageFlags <$> parseJSON val - -instance ToJSON PackageFlags where - toJSON = toJSON . unPackageFlags - -instance Monoid PackageFlags where - mempty = PackageFlags mempty - mappend (PackageFlags l) (PackageFlags r) = - PackageFlags (Map.unionWith Map.union l r) - ----------------------------------- -- Lens classes ----------------------------------- @@ -1846,28 +1857,21 @@ 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 }) +wantedCompilerVersionL :: HasBuildConfig s => Getting r s (CompilerVersion 'CVWanted) +wantedCompilerVersionL = snapshotDefL.to sdWantedCompilerVersion -- | 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 :: HasEnvConfig s => Lens' s (CompilerVersion 'CVActual) 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 }) +snapshotDefL :: HasBuildConfig s => Lens' s SnapshotDef +snapshotDefL = buildConfigL.lens + bcSnapshotDef + (\x y -> x { bcSnapshotDef = y }) packageIndicesL :: HasConfig s => Lens' s [PackageIndex] packageIndicesL = configL.lens @@ -1916,7 +1920,7 @@ globalOptsBuildOptsMonoidL = globalOptsL.lens packageCachesL :: HasConfig env => Lens' env (IORef (Maybe (Map PackageIdentifier (PackageIndex, PackageCache) - ,HashMap GitSHA1 (PackageIndex, OffsetSize)))) + ,HashMap CabalHash (PackageIndex, OffsetSize)))) packageCachesL = configL.lens configPackageCaches (\x y -> x { configPackageCaches = y }) configUrlsL :: HasConfig env => Lens' env Urls @@ -1927,5 +1931,15 @@ cabalVersionL = envConfigL.lens envConfigCabalVersion (\x y -> x { envConfigCabalVersion = y }) -whichCompilerL :: Getting r CompilerVersion WhichCompiler +loadedSnapshotL :: HasEnvConfig env => Lens' env LoadedSnapshot +loadedSnapshotL = envConfigL.lens + envConfigLoadedSnapshot + (\x y -> x { envConfigLoadedSnapshot = y }) + +whichCompilerL :: Getting r (CompilerVersion a) WhichCompiler whichCompilerL = to whichCompiler + +envOverrideL :: HasConfig env => Lens' env (EnvSettings -> IO EnvOverride) +envOverrideL = configL.lens + configEnvOverride + (\x y -> x { configEnvOverride = y }) diff --git a/src/Stack/Types/Config.hs-boot b/src/Stack/Types/Config.hs-boot index e842c0de0d..101c89bca8 100644 --- a/src/Stack/Types/Config.hs-boot +++ b/src/Stack/Types/Config.hs-boot @@ -2,7 +2,7 @@ module Stack.Types.Config where -import Control.Exception +import Control.Monad.IO.Unlift import Data.List.NonEmpty (NonEmpty) import Distribution.Version import Data.Text (Text) diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs index 8e572ebd8c..38ffda7bcd 100644 --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -9,7 +9,7 @@ module Stack.Types.Docker where import Control.Applicative -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Aeson.Extended import Data.List (intercalate) import Data.Monoid diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs index 4da92f3c10..7c514cae42 100644 --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -23,7 +23,7 @@ module Stack.Types.FlagName import Control.Applicative import Control.DeepSeq (NFData) -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs index bc484a27d8..a4e12a74b4 100644 --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -12,7 +12,7 @@ module Stack.Types.GhcPkgId import Control.Applicative import Control.DeepSeq -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Aeson.Extended import Data.Attoparsec.Text import Data.Binary (Binary(..), putWord8, getWord8) diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index be72537e06..079cb18c3e 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -9,7 +9,7 @@ module Stack.Types.Package where import Control.DeepSeq -import Control.Exception hiding (try,catch) +import Control.Monad.IO.Unlift import qualified Data.ByteString as S import Data.Data import Data.Function @@ -36,7 +36,7 @@ import Distribution.System (Platform (..)) import GHC.Generics (Generic) import Path as FL import Prelude -import Stack.Types.BuildPlan (GitSHA1) +import Stack.Types.BuildPlan (PackageLocationIndex) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -177,7 +177,8 @@ data PackageConfig = ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Configured flags. ,packageConfigGhcOptions :: ![Text] -- ^ Configured ghc options. - ,packageConfigCompilerVersion :: !CompilerVersion -- ^ GHC version + ,packageConfigCompilerVersion + :: !(CompilerVersion 'CVActual) -- ^ GHC version ,packageConfigPlatform :: !Platform -- ^ host platform } deriving (Show,Typeable) @@ -195,7 +196,7 @@ type SourceMap = Map PackageName PackageSource -- | Where the package's source is located: local directory or package index data PackageSource = PSLocal LocalPackage - | PSUpstream Version InstallLocation (Map FlagName Bool) [Text] (Maybe GitSHA1) + | PSUpstream Version InstallLocation (Map FlagName Bool) [Text] (PackageLocationIndex FilePath) -- FIXME still seems like we could do better... Minimum: rename from Upstream to Dependency and Local to Project -- ^ Upstream packages could be installed in either local or snapshot -- databases; this is what 'InstallLocation' specifies. deriving Show @@ -249,14 +250,6 @@ data LocalPackage = LocalPackage } deriving Show --- | A single, fully resolved component of a package -data NamedComponent - = CLib - | CExe !Text - | CTest !Text - | CBench !Text - deriving (Show, Eq, Ord) - renderComponent :: NamedComponent -> S.ByteString renderComponent CLib = "lib" renderComponent (CExe x) = "exe:" <> encodeUtf8 x diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs index 6121f09756..e573a2cc72 100644 --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -1,33 +1,55 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Package identifier (name-version). module Stack.Types.PackageIdentifier ( PackageIdentifier(..) + , PackageIdentifierRevision(..) + , CabalHash + , mkCabalHashFromSHA256 + , computeCabalHash + , showCabalHash + , CabalFileInfo(..) , toTuple , fromTuple , parsePackageIdentifier , parsePackageIdentifierFromString + , parsePackageIdentifierRevision , packageIdentifierParser , packageIdentifierString + , packageIdentifierRevisionString , packageIdentifierText - , toCabalPackageIdentifier ) + , toCabalPackageIdentifier + , fromCabalPackageIdentifier + , StaticSHA256 + , mkStaticSHA256FromText + , staticSHA256ToText + , staticSHA256ToBase16 + ) where import Control.Applicative import Control.DeepSeq -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.IO.Unlift +import Crypto.Hash as Hash (hashlazy, Digest, SHA256) import Data.Aeson.Extended -import Data.Attoparsec.Text +import Data.Attoparsec.Text as A +import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L import Data.Data import Data.Hashable import Data.Store (Store) +import Data.Store.Internal (Size (..), StaticSize (..), size, + toStaticSize, toStaticSizeEx, unStaticSize) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Distribution.Package as C import GHC.Generics import Prelude hiding (FilePath) @@ -35,11 +57,13 @@ import Stack.Types.PackageName import Stack.Types.Version -- | A parse fail. -newtype PackageIdentifierParseFail +data PackageIdentifierParseFail = PackageIdentifierParseFail Text + | PackageIdentifierRevisionParseFail Text deriving (Typeable) instance Show PackageIdentifierParseFail where show (PackageIdentifierParseFail bs) = "Invalid package identifier: " ++ show bs + show (PackageIdentifierRevisionParseFail bs) = "Invalid package identifier (with optional revision): " ++ show bs instance Exception PackageIdentifierParseFail -- | A pkg-ver combination. @@ -68,6 +92,98 @@ instance FromJSON PackageIdentifier where Left e -> fail $ show (e, t) Right x -> return x +-- | A 'PackageIdentifier' combined with optionally specified Hackage +-- cabal file revision. +data PackageIdentifierRevision = PackageIdentifierRevision + { pirIdent :: !PackageIdentifier + , pirRevision :: !(Maybe CabalFileInfo) + } deriving (Eq,Generic,Data,Typeable) + +instance NFData PackageIdentifierRevision where + rnf (PackageIdentifierRevision !i !c) = + seq (rnf i) (rnf c) + +instance Hashable PackageIdentifierRevision +instance Store PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = show . packageIdentifierRevisionString + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . packageIdentifierRevisionString +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show (e, t) + Right x -> return x + +-- | A cryptographic hash of a Cabal file. +newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 } + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Store, Hashable) + +-- | A SHA256 hash, stored in a static size for more efficient +-- serialization with store. +newtype StaticSHA256 = StaticSHA256 (StaticSize 64 ByteString) + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord) + +instance Store StaticSHA256 where + size = ConstSize 64 + -- poke (GitSHA1 x) = do + -- let (sourceFp, sourceOffset, sourceLength) = BSI.toForeignPtr (unStaticSize x) + -- pokeFromForeignPtr sourceFp sourceOffset sourceLength + -- peek = do + -- let len = 20 + -- fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len + -- return (GitSHA1 $ StaticSize (BSI.PS fp 0 len)) + -- {-# INLINE size #-} + -- {-# INLINE peek #-} + -- {-# INLINE poke #-} + +instance Hashable StaticSHA256 where + hashWithSalt s (StaticSHA256 x) = hashWithSalt s (unStaticSize x) + +-- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash. +mkStaticSHA256FromText :: Text -> Maybe StaticSHA256 +mkStaticSHA256FromText = fmap StaticSHA256 . toStaticSize . encodeUtf8 + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToText :: StaticSHA256 -> Text +staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16 + +-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash. +staticSHA256ToBase16 :: StaticSHA256 -> ByteString +staticSHA256ToBase16 (StaticSHA256 x) = unStaticSize x + +-- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash. +mkCabalHashFromSHA256 :: Text -> Maybe CabalHash +mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText + +-- | Convert a 'CabalHash' into a base16-encoded SHA256 hash. +cabalHashToText :: CabalHash -> Text +cabalHashToText = staticSHA256ToText . unCabalHash + +-- | Compute a 'CabalHash' value from a cabal file's contents. +computeCabalHash :: L.ByteString -> CabalHash +computeCabalHash = CabalHash . StaticSHA256 . toStaticSizeEx . Mem.convertToBase Mem.Base16 . hashSHA256 + +hashSHA256 :: L.ByteString -> Hash.Digest Hash.SHA256 +hashSHA256 = Hash.hashlazy + +showCabalHash :: CabalHash -> Text +showCabalHash = T.append (T.pack "sha256:") . cabalHashToText + +-- | Information on the contents of a cabal file +data CabalFileInfo = CabalFileInfo + { cfiSize :: !(Maybe Int) + -- ^ File size in bytes + , cfiHash :: !CabalHash + -- ^ Hash of the cabal file contents + } + deriving (Generic, Show, Eq, Data, Typeable) +instance Store CabalFileInfo +instance NFData CabalFileInfo +instance Hashable CabalFileInfo + -- | Convert from a package identifier to a tuple. toTuple :: PackageIdentifier -> (PackageName,Version) toTuple (PackageIdentifier n v) = (n,v) @@ -96,10 +212,51 @@ parsePackageIdentifierFromString :: MonadThrow m => String -> m PackageIdentifie parsePackageIdentifierFromString = parsePackageIdentifier . T.pack +-- | Parse a 'PackageIdentifierRevision' +parsePackageIdentifierRevision :: MonadThrow m => Text -> m PackageIdentifierRevision +parsePackageIdentifierRevision x = go x + where + go = + either (const (throwM (PackageIdentifierRevisionParseFail x))) return . + parseOnly (parser <* endOfInput) + + parser = PackageIdentifierRevision + <$> packageIdentifierParser + <*> optional cabalFileInfo + + cabalFileInfo = do + _ <- string $ T.pack "@sha256:" + hash' <- A.takeWhile (/= ',') + hash'' <- maybe (fail "Invalid SHA256") return + $ mkCabalHashFromSHA256 hash' + msize <- optional $ do + _ <- A.char ',' + A.decimal + return CabalFileInfo + { cfiSize = msize + , cfiHash = hash'' + } + -- | Get a string representation of the package identifier; name-ver. packageIdentifierString :: PackageIdentifier -> String packageIdentifierString (PackageIdentifier n v) = show n ++ "-" ++ show v +-- | Get a string representation of the package identifier with revision; name-ver[@hashtype:hash[,size]]. +packageIdentifierRevisionString :: PackageIdentifierRevision -> String +packageIdentifierRevisionString (PackageIdentifierRevision ident mcfi) = + concat $ packageIdentifierString ident : rest + where + rest = + case mcfi of + Nothing -> [] + Just cfi -> + "@sha256:" + : T.unpack (cabalHashToText (cfiHash cfi)) + : showSize (cfiSize cfi) + + showSize Nothing = [] + showSize (Just int) = [',' : show int] + -- | Get a Text representation of the package identifier; name-ver. packageIdentifierText :: PackageIdentifier -> Text packageIdentifierText = T.pack . packageIdentifierString @@ -109,3 +266,9 @@ toCabalPackageIdentifier x = C.PackageIdentifier (toCabalPackageName (packageIdentifierName x)) (toCabalVersion (packageIdentifierVersion x)) + +fromCabalPackageIdentifier :: C.PackageIdentifier -> PackageIdentifier +fromCabalPackageIdentifier (C.PackageIdentifier name version) = + PackageIdentifier + (fromCabalPackageName name) + (fromCabalVersion version) diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 081a697ec7..82b96267f8 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -38,7 +38,6 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Word (Word64) import GHC.Generics (Generic) import Path -import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.PackageIdentifier data PackageCache = PackageCache @@ -61,25 +60,30 @@ 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 + , pcmSHA :: !(HashMap CabalHash OffsetSize) + -- ^ lookup via the cabal hash of the cabal file contents } deriving (Generic, Eq, Show, Data, Typeable) instance Store PackageCacheMap instance NFData PackageCacheMap data PackageDownload = PackageDownload - { pdSHA256 :: !ByteString + { pdSHA256 :: !StaticSHA256 , pdUrl :: !ByteString , pdSize :: !Word64 } deriving (Show, Generic, Eq, Data, Typeable) + instance Store PackageDownload instance NFData PackageDownload instance FromJSON PackageDownload where parseJSON = withObject "PackageDownload" $ \o -> do hashes <- o .: "package-hashes" - sha256 <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) + sha256' <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes) + sha256 <- + case mkStaticSHA256FromText sha256' of + Nothing -> fail "Invalid sha256" + Just x -> return x locs <- o .: "package-locations" url <- case reverse locs of @@ -87,7 +91,7 @@ instance FromJSON PackageDownload where x:_ -> return x size <- o .: "package-size" return PackageDownload - { pdSHA256 = encodeUtf8 sha256 + { pdSHA256 = sha256 , pdUrl = encodeUtf8 url , pdSize = size } @@ -102,9 +106,13 @@ instance FromJSON HSPackageDownload where Object o4:_ <- return $ F.toList o3 len <- o4 .: "length" hashes <- o4 .: "hashes" - sha256 <- hashes .: "sha256" + sha256' <- hashes .: "sha256" + sha256 <- + case mkStaticSHA256FromText sha256' of + Nothing -> fail "Invalid sha256" + Just x -> return x return $ HSPackageDownload PackageDownload - { pdSHA256 = encodeUtf8 sha256 + { pdSHA256 = sha256 , pdSize = len , pdUrl = "" } diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs index 3e10ed1c25..fb0d3dc6cf 100644 --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -26,7 +26,7 @@ module Stack.Types.PackageName import Control.Applicative import Control.DeepSeq import Control.Monad -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Aeson.Extended import Data.Attoparsec.Combinators import Data.Attoparsec.Text diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index 83b807d8ca..f2e5d991c6 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -1,5 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -10,125 +15,131 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Stack.Types.Resolver (Resolver ,IsLoaded(..) ,LoadedResolver - ,ResolverThat's(..) + ,ResolverWith(..) ,parseResolverText - ,resolverDirName - ,resolverName - ,customResolverHash - ,toResolverNotLoaded ,AbstractResolver(..) ,readAbstractResolver + ,resolverRawName + ,SnapName(..) + ,Snapshots (..) + ,renderSnapName + ,parseSnapName + ,SnapshotHash (..) + ,trimmedSnapshotHash + ,parseCustomLocation ) where import Control.Applicative -import Control.Monad.Catch (MonadThrow, throwM) +import Control.DeepSeq (NFData) +import Control.Monad.IO.Unlift import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, object, - WithJSONWarnings(..), Value(String, Object), (.=), - noJSONWarnings, (..:), withObjectWarnings) -import Data.Monoid.Extra + (ToJSON, toJSON, FromJSON, parseJSON, + withObject, (.:), withText) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Data (Data) +import qualified Data.HashMap.Strict as HashMap +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Store (Store) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) import Data.Text.Read (decimal) +import Data.Time (Day) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Client (Request, parseUrlThrow) import Options.Applicative (ReadM) -import qualified Options.Applicative as OA import qualified Options.Applicative.Types as OA +import Path import Prelude -import Stack.Types.BuildPlan (parseSnapName, renderSnapName, SnapName, SnapshotHash, - trimmedSnapshotHash) -import {-# SOURCE #-} Stack.Types.Config (ConfigException(..)) +import Safe (readMay) import Stack.Types.Compiler +import qualified System.FilePath as FP data IsLoaded = Loaded | NotLoaded -type LoadedResolver = ResolverThat's 'Loaded -type Resolver = ResolverThat's 'NotLoaded +type LoadedResolver = ResolverWith SnapshotHash +type Resolver = ResolverWith (Either Request (Path Abs File)) -- TODO: once GHC 8.0 is the lowest version we support, make these into -- actual haddock comments... -- | How we resolve which dependencies to install given a set of packages. -data ResolverThat's (l :: IsLoaded) where - -- Use an official snapshot from the Stackage project, either an LTS - -- Haskell or Stackage Nightly. - ResolverSnapshot :: !SnapName -> ResolverThat's l - -- Require a specific compiler version, but otherwise provide no +data ResolverWith customContents + = ResolverSnapshot !SnapName -- FIXME rename to ResolverStackage + -- ^ Use an official snapshot from the Stackage project, either an + -- LTS Haskell or Stackage Nightly. + + | ResolverCompiler !(CompilerVersion 'CVWanted) + -- ^ Require a specific compiler version, but otherwise provide no -- build plan. Intended for use cases where end user wishes to -- specify all upstream dependencies manually, such as using a -- dependency solver. - ResolverCompiler :: !CompilerVersion -> ResolverThat's l - -- A custom resolver based on the given name and URL. When a URL is - -- provided, it file is to be completely immutable. Filepaths are - -- always loaded. This constructor is used before the build-plan has - -- been loaded, as we do not yet know the custom snapshot's hash. - ResolverCustom :: !Text -> !Text -> ResolverThat's 'NotLoaded - -- Like 'ResolverCustom', but after loading the build-plan, so we - -- have a hash. This is necessary in order to identify the location - -- files are stored for the resolver. - ResolverCustomLoaded :: !Text -> !Text -> !SnapshotHash -> ResolverThat's 'Loaded - -deriving instance Eq (ResolverThat's k) -deriving instance Show (ResolverThat's k) - -instance ToJSON (ResolverThat's k) where + + | ResolverCustom !Text !customContents + -- ^ A custom resolver based on the given location (as a raw URL + -- or filepath). If @customContents@ is a @Either Request + -- FilePath@, it represents the parsed location value (with + -- filepaths resolved relative to the directory containing the + -- file referring to the custom snapshot). Once it has been loaded + -- from disk, it will be replaced with a @SnapshotHash@ value, + -- which is used to store cached files. + deriving (Generic, Typeable, Show, Data, Eq, Functor, Foldable, Traversable) +instance Store LoadedResolver +instance NFData LoadedResolver + +instance ToJSON (ResolverWith a) where toJSON x = case x of - ResolverSnapshot{} -> toJSON $ resolverName x - ResolverCompiler{} -> toJSON $ resolverName x - ResolverCustom n l -> handleCustom n l - ResolverCustomLoaded n l _ -> handleCustom n l - where - handleCustom n l = object - [ "name" .= n - , "location" .= l - ] -instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where - -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom - <$> o ..: "name" - <*> o ..: "location") v - - parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t) - - parseJSON _ = fail "Invalid Resolver, must be Object or String" - --- | Convert a Resolver into its @Text@ representation, as will be used by --- directory names -resolverDirName :: LoadedResolver -> Text -resolverDirName (ResolverSnapshot name) = renderSnapName name -resolverDirName (ResolverCompiler v) = compilerVersionText v -resolverDirName (ResolverCustomLoaded name _ hash) = "custom-" <> name <> "-" <> decodeUtf8 (trimmedSnapshotHash hash) + ResolverSnapshot name -> toJSON $ renderSnapName name + ResolverCompiler version -> toJSON $ compilerVersionText version + ResolverCustom loc _ -> toJSON loc +instance a ~ () => FromJSON (ResolverWith a) where + parseJSON = withText "ResolverWith ()" $ return . parseResolverText -- | Convert a Resolver into its @Text@ representation for human --- presentation. -resolverName :: ResolverThat's l -> Text -resolverName (ResolverSnapshot name) = renderSnapName name -resolverName (ResolverCompiler v) = compilerVersionText v -resolverName (ResolverCustom name _) = "custom-" <> name -resolverName (ResolverCustomLoaded name _ _) = "custom-" <> name - -customResolverHash :: LoadedResolver-> Maybe SnapshotHash -customResolverHash (ResolverCustomLoaded _ _ hash) = Just hash -customResolverHash _ = Nothing - --- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom). -parseResolverText :: MonadThrow m => Text -> m Resolver +-- presentation. When possible, you should prefer @sdResolverName@, as +-- it will handle the human-friendly name inside a custom snapshot. +resolverRawName :: ResolverWith a -> Text +resolverRawName (ResolverSnapshot name) = renderSnapName name +resolverRawName (ResolverCompiler v) = compilerVersionText v +resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc + +parseCustomLocation + :: MonadThrow m + => Maybe (Path Abs Dir) -- ^ directory config value was read from + -> ResolverWith () -- could technically be any type parameter, restricting to help with type safety + -> m Resolver +parseCustomLocation mdir (ResolverCustom t ()) = + ResolverCustom t <$> case parseUrlThrow $ T.unpack t of + Nothing -> Right <$> do + dir <- + case mdir of + Nothing -> throwM $ FilepathInDownloadedSnapshot t + Just x -> return x + let rel = + T.unpack + $ fromMaybe t + $ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t + parseAbsFile $ toFilePath dir FP. rel + Just req -> return $ Left req +parseCustomLocation _ (ResolverSnapshot name) = return $ ResolverSnapshot name +parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv + +-- | Parse a @Resolver@ from a @Text@ +parseResolverText :: Text -> ResolverWith () parseResolverText t - | Right x <- parseSnapName t = return $ ResolverSnapshot x - | Just v <- parseCompilerVersion t = return $ ResolverCompiler v - | otherwise = throwM $ ParseResolverException t - -toResolverNotLoaded :: LoadedResolver -> Resolver -toResolverNotLoaded r = case r of - ResolverSnapshot s -> ResolverSnapshot s - ResolverCompiler v -> ResolverCompiler v - ResolverCustomLoaded n l _ -> ResolverCustom n l + | Right x <- parseSnapName t = ResolverSnapshot x + | Just v <- parseCompilerVersion t = ResolverCompiler v + | otherwise = ResolverCustom t () -- | Either an actual resolver value, or an abstract description of one (e.g., -- latest nightly). @@ -136,7 +147,7 @@ data AbstractResolver = ARLatestNightly | ARLatestLTS | ARLatestLTSMajor !Int - | ARResolver !Resolver + | ARResolver !(ResolverWith ()) | ARGlobal deriving Show @@ -149,7 +160,90 @@ readAbstractResolver = do "lts" -> return ARLatestLTS 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x -> return $ ARLatestLTSMajor x' - _ -> - case parseResolverText $ T.pack s of - Left e -> OA.readerError $ show e - Right x -> return $ ARResolver x + _ -> return $ ARResolver $ parseResolverText $ T.pack s + +-- | The name of an LTS Haskell or Stackage Nightly snapshot. +data SnapName + = LTS !Int !Int + | Nightly !Day + deriving (Generic, Typeable, Show, Data, Eq) +instance Store SnapName +instance NFData SnapName + +data BuildPlanTypesException + = ParseSnapNameException !Text + | ParseResolverException !Text + | FilepathInDownloadedSnapshot !Text + deriving Typeable +instance Exception BuildPlanTypesException +instance Show BuildPlanTypesException where + show (ParseSnapNameException t) = "Invalid snapshot name: " ++ T.unpack t + show (ParseResolverException t) = concat + [ "Invalid resolver value: " + , T.unpack t + , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. " + , "See https://www.stackage.org/snapshots for a complete list." + ] + show (FilepathInDownloadedSnapshot url) = unlines + [ "Downloaded snapshot specified a 'resolver: { location: filepath }' " + , "field, but filepaths are not allowed in downloaded snapshots.\n" + , "Filepath specified: " ++ T.unpack url + ] + +-- | Convert a 'SnapName' into its short representation, e.g. @lts-2.8@, +-- @nightly-2015-03-05@. +renderSnapName :: SnapName -> Text +renderSnapName (LTS x y) = T.pack $ concat ["lts-", show x, ".", show y] +renderSnapName (Nightly d) = T.pack $ "nightly-" ++ show d + +-- | Parse the short representation of a 'SnapName'. +parseSnapName :: MonadThrow m => Text -> m SnapName +parseSnapName t0 = + case lts <|> nightly of + Nothing -> throwM $ ParseSnapNameException t0 + Just sn -> return sn + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMay (T.unpack t1) + +-- | Most recent Nightly and newest LTS version per major release. +data Snapshots = Snapshots + { snapshotsNightly :: !Day + , snapshotsLts :: !(IntMap Int) + } + deriving Show +instance FromJSON Snapshots where + parseJSON = withObject "Snapshots" $ \o -> Snapshots + <$> (o .: "nightly" >>= parseNightly) + <*> fmap IntMap.unions (mapM (parseLTS . snd) + $ filter (isLTS . fst) + $ HashMap.toList o) + where + parseNightly t = + case parseSnapName t of + Left e -> fail $ show e + Right (LTS _ _) -> fail "Unexpected LTS value" + Right (Nightly d) -> return d + + isLTS = ("lts-" `T.isPrefixOf`) + + parseLTS = withText "LTS" $ \t -> + case parseSnapName t of + Left e -> fail $ show e + Right (LTS x y) -> return $ IntMap.singleton x y + Right (Nightly _) -> fail "Unexpected nightly value" + +newtype SnapshotHash = SnapshotHash { unShapshotHash :: ByteString } + deriving (Generic, Typeable, Show, Data, Eq) +instance Store SnapshotHash +instance NFData SnapshotHash + +trimmedSnapshotHash :: SnapshotHash -> ByteString +trimmedSnapshotHash = BS.take 12 . unShapshotHash diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs index 0cc70ee546..87d06ae17e 100644 --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -18,7 +18,7 @@ module Stack.Types.Sig import Prelude () import Prelude.Compat -import Control.Exception (Exception) +import Control.Monad.IO.Unlift import Data.Aeson (Value(..), ToJSON(..), FromJSON(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as SB diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs index 619f1ff899..e3f683b45f 100644 --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -26,14 +26,11 @@ module Stack.Types.StackT where import Control.Applicative -import Control.Concurrent.MVar import Control.Monad import Control.Monad.Base -import Control.Monad.Catch -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader hiding (lift) -import Control.Monad.Trans.Control import qualified Data.ByteString.Char8 as S8 import Data.Char import Data.List (stripPrefix) @@ -68,7 +65,7 @@ type HasEnv r = (HasLogOptions r, HasTerminal r, HasReExec r, HasSticky r) -- | Constraint synonym for constraints commonly satisifed by monads used in stack. type StackM r m = - (MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m, HasEnv r) + (MonadReader r m, MonadUnliftIO m, MonadLoggerIO m, MonadThrow m, HasEnv r) -------------------------------------------------------------------------------- -- Main StackT monad transformer @@ -76,20 +73,10 @@ type StackM r m = -- | The monad used for the executable @stack@. newtype StackT config m a = StackT {unStackT :: ReaderT (Env config) m a} - deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadCatch,MonadMask,MonadTrans) + deriving (Functor,Applicative,Monad,MonadIO,MonadReader (Env config),MonadThrow,MonadTrans) deriving instance (MonadBase b m) => MonadBase b (StackT config m) -instance MonadBaseControl b m => MonadBaseControl b (StackT config m) where - type StM (StackT config m) a = ComposeSt (StackT config) m a - liftBaseWith = defaultLiftBaseWith - restoreM = defaultRestoreM - -instance MonadTransControl (StackT config) where - type StT (StackT config) a = StT (ReaderT (Env config)) a - liftWith = defaultLiftWith StackT unStackT - restoreT = defaultRestoreT StackT - -- | Takes the configured log level into account. instance MonadIO m => MonadLogger (StackT config m) where monadLoggerLog = stickyLoggerFunc @@ -97,6 +84,11 @@ instance MonadIO m => MonadLogger (StackT config m) where instance MonadIO m => MonadLoggerIO (StackT config m) where askLoggerIO = getStickyLoggerFunc +instance MonadUnliftIO m => MonadUnliftIO (StackT config m) where + askUnliftIO = StackT $ ReaderT $ \r -> + withUnliftIO $ \u -> + return (UnliftIO (unliftIO u . flip runReaderT r . unStackT)) + -- | Run a Stack action, using global options. runStackTGlobal :: (MonadIO m) => config -> GlobalOpts -> StackT config m a -> m a @@ -133,7 +125,7 @@ getCanUseUnicode = do test = withCString enc str $ \cstr -> do str' <- peekCString enc cstr return (str == str') - test `catchIOError` \_ -> return False + test `catchIO` \_ -> return False runInnerStackT :: (HasEnv r, MonadReader r m, MonadIO m) => config -> StackT config IO a -> m a diff --git a/src/Stack/Types/StringError.hs b/src/Stack/Types/StringError.hs index a9327e31e6..643a43c707 100644 --- a/src/Stack/Types/StringError.hs +++ b/src/Stack/Types/StringError.hs @@ -2,8 +2,7 @@ module Stack.Types.StringError where -import Control.Exception -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Typeable import GHC.Prim diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs index c538fb380b..f0e95493e6 100644 --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -33,7 +33,7 @@ module Stack.Types.Version import Control.Applicative import Control.DeepSeq -import Control.Monad.Catch +import Control.Monad.IO.Unlift import Data.Aeson.Extended import Data.Attoparsec.Text import Data.Data diff --git a/src/Stack/Types/VersionIntervals.hs b/src/Stack/Types/VersionIntervals.hs new file mode 100644 index 0000000000..2eb537bf79 --- /dev/null +++ b/src/Stack/Types/VersionIntervals.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Stack.Types.VersionIntervals + ( VersionIntervals + , toVersionRange + , fromVersionRange + , withinIntervals + , unionVersionIntervals + , intersectVersionIntervals + ) where + +import Stack.Types.Version +import qualified Distribution.Version as C +import Control.DeepSeq (NFData) +import Data.Maybe (fromMaybe) +import Data.Store (Store) +import GHC.Generics (Generic) +import Data.Data (Data) +import Data.Typeable (Typeable) + +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Generic, Show, Eq, Data, Typeable) +instance Store VersionIntervals +instance NFData VersionIntervals + +data VersionInterval = VersionInterval + { viLowerVersion :: !Version + , viLowerBound :: !Bound + , viUpper :: !(Maybe (Version, Bound)) + } + deriving (Generic, Show, Eq, Data, Typeable) +instance Store VersionInterval +instance NFData VersionInterval + +data Bound = ExclusiveBound | InclusiveBound + deriving (Generic, Show, Eq, Data, Typeable) +instance Store Bound +instance NFData Bound + +toVersionRange :: VersionIntervals -> C.VersionRange +toVersionRange = C.fromVersionIntervals . toCabal + +fromVersionRange :: C.VersionRange -> VersionIntervals +fromVersionRange = fromCabal . C.toVersionIntervals + +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v vi = C.withinIntervals (toCabalVersion v) (toCabal vi) + +unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals +unionVersionIntervals x y = fromCabal $ C.unionVersionIntervals + (toCabal x) + (toCabal y) + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals +intersectVersionIntervals x y = fromCabal $ C.intersectVersionIntervals + (toCabal x) + (toCabal y) + +toCabal :: VersionIntervals -> C.VersionIntervals +toCabal (VersionIntervals vi) = fromMaybe + (error "Stack.Types.VersionIntervals.toCabal: invariant violated") + (C.mkVersionIntervals $ map go vi) + where + go (VersionInterval lowerV lowerB mupper) = + ( C.LowerBound (toCabalVersion lowerV) (toCabalBound lowerB) + , case mupper of + Nothing -> C.NoUpperBound + Just (v, b) -> C.UpperBound (toCabalVersion v) (toCabalBound b) + ) + +fromCabal :: C.VersionIntervals -> VersionIntervals +fromCabal = + VersionIntervals . map go . C.versionIntervals + where + go (C.LowerBound lowerV lowerB, upper) = VersionInterval + { viLowerVersion = fromCabalVersion lowerV + , viLowerBound = fromCabalBound lowerB + , viUpper = + case upper of + C.NoUpperBound -> Nothing + C.UpperBound v b -> Just (fromCabalVersion v, fromCabalBound b) + } + +toCabalBound :: Bound -> C.Bound +toCabalBound ExclusiveBound = C.ExclusiveBound +toCabalBound InclusiveBound = C.InclusiveBound + +fromCabalBound :: C.Bound -> Bound +fromCabalBound C.ExclusiveBound = ExclusiveBound +fromCabalBound C.InclusiveBound = InclusiveBound diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 7966d0b824..63cc5a11b2 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -11,9 +11,8 @@ module Stack.Upgrade , upgradeOpts ) where -import Control.Exception.Safe (catchAny) import Control.Monad (unless, when) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.Foldable (forM_) import qualified Data.Map as Map @@ -160,7 +159,7 @@ binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do toUpgrade <- case (force, isNewer) of (False, False) -> do - $logInfo "Skipping binary upgrade, your version is already more recent" + $logInfo "Skipping binary upgrade, you are already running the most recent version" return False (True, False) -> do $logInfo "Forcing binary upgrade" @@ -185,7 +184,7 @@ sourceUpgrade -> SourceOpts -> m () sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = - withSystemTempDir "stack-upgrade" $ \tmp -> do + withRunIO $ \run -> withSystemTempDir "stack-upgrade" $ \tmp -> run $ do menv <- getMinimalEnvOverride mdir <- case gitRepo of Just repo -> do @@ -231,7 +230,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = let ident = PackageIdentifier $(mkPackageName "stack") version paths <- unpackPackageIdents tmp Nothing -- accept latest cabal revision by not supplying a Git SHA - $ Map.singleton ident Nothing + [PackageIdentifierRevision ident Nothing] case Map.lookup ident paths of Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" Just path -> return $ Just path diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 084bed0392..34d731cb92 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -1,39 +1,24 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Provide ability to upload tarballs to Hackage. module Stack.Upload ( -- * Upload - nopUploader - , mkUploader - , Uploader - , upload + upload , uploadBytes - , UploadSettings - , defaultUploadSettings - , setUploadUrl - , setCredsSource - , setSaveCreds + , uploadRevision -- * Credentials , HackageCreds , loadCreds - , saveCreds - , FromFile - -- ** Credentials source - , HackageCredsSource - , fromAnywhere - , fromPrompt - , fromFile - , fromMemory ) where import Control.Applicative -import Control.Exception (bracket) -import qualified Control.Exception as E -import Control.Monad (when) +import Control.Monad (void, when, unless) +import Control.Monad.IO.Unlift import Data.Aeson (FromJSON (..), ToJSON (..), - eitherDecode', encode, + decode', encode, object, withObject, (.:), (.=)) import qualified Data.ByteString.Char8 as S @@ -44,27 +29,32 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.IO as TIO -import Data.Typeable (Typeable) import Network.HTTP.Client (Response, - RequestBody(RequestBodyLBS)) + RequestBody(RequestBodyLBS), + Request) import Network.HTTP.Simple (withResponse, getResponseStatusCode, getResponseBody, setRequestHeader, - parseRequest) -import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody) + parseRequest, + httpNoBody) +import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, + partBS, partLBS) import Network.HTTP.Client.TLS (getGlobalManager, applyDigestAuth, displayDigestAuthException) import Path (toFilePath) import Prelude -- Fix redundant import warnings import Stack.Types.Config +import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString, + packageIdentifierName) +import Stack.Types.PackageName (packageNameString) import Stack.Types.StringError import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath ((), takeFileName) -import System.IO (hFlush, hGetEcho, hSetEcho, - stdin, stdout) +import System.IO (hFlush, stdout) +import System.IO.Echo (withoutInputEcho) -- | Username and password to log into Hackage. -- @@ -72,62 +62,52 @@ import System.IO (hFlush, hGetEcho, hSetEc data HackageCreds = HackageCreds { hcUsername :: !Text , hcPassword :: !Text + , hcCredsFile :: !FilePath } deriving Show instance ToJSON HackageCreds where - toJSON (HackageCreds u p) = object + toJSON (HackageCreds u p _) = object [ "username" .= u , "password" .= p ] -instance FromJSON HackageCreds where +instance FromJSON (FilePath -> HackageCreds) where parseJSON = withObject "HackageCreds" $ \o -> HackageCreds <$> o .: "username" <*> o .: "password" --- | A source for getting Hackage credentials. --- --- Since 0.1.0.0 -newtype HackageCredsSource = HackageCredsSource - { getCreds :: IO (HackageCreds, FromFile) - } - --- | Whether the Hackage credentials were loaded from a file. --- --- This information is useful since, typically, you only want to save the --- credentials to a file if it wasn't already loaded from there. --- --- Since 0.1.0.0 -type FromFile = Bool - --- | Load Hackage credentials from the given source. --- --- Since 0.1.0.0 -loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile) -loadCreds = getCreds - --- | Save the given credentials to the credentials file. --- --- Since 0.1.0.0 -saveCreds :: Config -> HackageCreds -> IO () -saveCreds config creds = do - fp <- credsFile config - L.writeFile fp $ encode creds - --- | Load the Hackage credentials from the prompt, asking the user to type them --- in. --- --- Since 0.1.0.0 -fromPrompt :: HackageCredsSource -fromPrompt = HackageCredsSource $ do - putStr "Hackage username: " - hFlush stdout - username <- TIO.getLine - password <- promptPassword - return (HackageCreds - { hcUsername = username - , hcPassword = password - }, False) +-- | Load Hackage credentials, either from a save file or the command +-- line. +-- +-- Since 0.1.0.0 +loadCreds :: Config -> IO HackageCreds +loadCreds config = do + fp <- credsFile config + elbs <- tryIO $ L.readFile fp + case either (const Nothing) Just elbs >>= decode' of + Nothing -> fromPrompt fp + Just mkCreds -> do + unless (configSaveHackageCreds config) $ do + putStrLn "WARNING: You've set save-hackage-creds to false" + putStrLn "However, credentials were found at:" + putStrLn $ " " ++ fp + return $ mkCreds fp + where + fromPrompt fp = do + when (configSaveHackageCreds config) $ do + putStrLn "NOTE: Username and password will be saved in a local file" + putStrLn "You can modify this behavior with the save-hackage-creds config option" + putStr "Hackage username: " + hFlush stdout + username <- TIO.getLine + password <- promptPassword + let hc = HackageCreds + { hcUsername = username + , hcPassword = password + , hcCredsFile = fp + } + L.writeFile fp (encode hc) + return hc credsFile :: Config -> IO FilePath credsFile config = do @@ -135,181 +115,96 @@ credsFile config = do createDirectoryIfMissing True dir return $ dir "credentials.json" --- | Load the Hackage credentials from the JSON config file. --- --- Since 0.1.0.0 -fromFile :: Config -> HackageCredsSource -fromFile config = HackageCredsSource $ do - fp <- credsFile config - lbs <- L.readFile fp - case eitherDecode' lbs of - Left e -> E.throwIO $ Couldn'tParseJSON fp e - Right creds -> return (creds, True) - --- | Load the Hackage credentials from the given arguments. --- --- Since 0.1.0.0 -fromMemory :: Text -> Text -> HackageCredsSource -fromMemory u p = HackageCredsSource $ return (HackageCreds - { hcUsername = u - , hcPassword = p - }, False) - -data HackageCredsExceptions = Couldn'tParseJSON FilePath String - deriving (Show, Typeable) -instance E.Exception HackageCredsExceptions - --- | Try to load the credentials from the config file. If that fails, ask the --- user to enter them. --- --- Since 0.1.0.0 -fromAnywhere :: Config -> HackageCredsSource -fromAnywhere config = HackageCredsSource $ - getCreds (fromFile config) `E.catches` - [ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt - , E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt - ] - -- | Lifted from cabal-install, Distribution.Client.Upload promptPassword :: IO Text promptPassword = do putStr "Hackage password: " hFlush stdout - -- save/restore the terminal echoing status - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap T.pack getLine + -- save/restore the terminal echoing status (no echoing for entering the password) + passwd <- withoutInputEcho $ fmap T.pack getLine putStrLn "" return passwd -nopUploader :: Config -> UploadSettings -> IO Uploader -nopUploader _ _ = return (Uploader nop) - where nop :: String -> L.ByteString -> IO () - nop _ _ = return () - --- | Turn the given settings into an @Uploader@. --- --- Since 0.1.0.0 -mkUploader :: Config -> UploadSettings -> IO Uploader -mkUploader config us = do - (creds, fromFile') <- loadCreds $ usCredsSource us config - when (not fromFile' && usSaveCreds us) $ saveCreds config creds - req0 <- parseRequest $ usUploadUrl us - let req1 = setRequestHeader "Accept" ["text/plain"] req0 - return Uploader - { upload_ = \tarName bytes -> do - let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] - req2 <- formDataBody formData req1 - manager <- getGlobalManager - ereq3 <- applyDigestAuth - (encodeUtf8 $ hcUsername creds) - (encodeUtf8 $ hcPassword creds) - req2 - manager - req3 <- - case ereq3 of - Left e -> do - putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" - case E.fromException e of - Just e' -> putStrLn $ displayDigestAuthException e' - Nothing -> print e - return req2 - Right req3 -> return req3 - putStr $ "Uploading " ++ tarName ++ "... " - hFlush stdout - withResponse req3 $ \res -> - case getResponseStatusCode res of - 200 -> putStrLn "done!" - 401 -> do - putStrLn "authentication failure" - cfp <- credsFile config - handleIO (const $ return ()) (removeFile cfp) - throwString "Authentication failure uploading to server" - 403 -> do - putStrLn "forbidden upload" - putStrLn "Usually means: you've already uploaded this package/version combination" - putStrLn "Ignoring error and continuing, full message from Hackage below:\n" - printBody res - 503 -> do - putStrLn "service unavailable" - putStrLn "This error some times gets sent even though the upload succeeded" - putStrLn "Check on Hackage to see if your pacakge is present" - printBody res - code -> do - putStrLn $ "unhandled status code: " ++ show code - printBody res - throwString $ "Upload failed on " ++ tarName - } - -printBody :: Response (ConduitM () S.ByteString IO ()) -> IO () -printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout - --- | The computed value from a @UploadSettings@. --- --- Typically, you want to use this with 'upload'. --- --- Since 0.1.0.0 -newtype Uploader = Uploader - { upload_ :: String -> L.ByteString -> IO () - } - --- | Upload a single tarball with the given @Uploader@. --- --- Since 0.1.0.0 -upload :: Uploader -> FilePath -> IO () -upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp +applyCreds :: HackageCreds -> Request -> IO Request +applyCreds creds req0 = do + manager <- getGlobalManager + ereq <- applyDigestAuth + (encodeUtf8 $ hcUsername creds) + (encodeUtf8 $ hcPassword creds) + req0 + manager + case ereq of + Left e -> do + putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" + case fromException e of + Just e' -> putStrLn $ displayDigestAuthException e' + Nothing -> print e + return req0 + Right req -> return req -- | Upload a single tarball with the given @Uploader@. Instead of -- sending a file like 'upload', this sends a lazy bytestring. -- -- Since 0.1.2.1 -uploadBytes :: Uploader -> String -> L.ByteString -> IO () -uploadBytes = upload_ - --- | Settings for creating an @Uploader@. --- --- Since 0.1.0.0 -data UploadSettings = UploadSettings - { usUploadUrl :: !String - , usCredsSource :: !(Config -> HackageCredsSource) - , usSaveCreds :: !Bool - } - --- | Default value for @UploadSettings@. --- --- Use setter functions to change defaults. --- --- Since 0.1.0.0 -defaultUploadSettings :: UploadSettings -defaultUploadSettings = UploadSettings - { usUploadUrl = "https://hackage.haskell.org/packages/" - , usCredsSource = fromAnywhere - , usSaveCreds = True - } - --- | Change the upload URL. --- --- Default: "https://hackage.haskell.org/packages/" --- --- Since 0.1.0.0 -setUploadUrl :: String -> UploadSettings -> UploadSettings -setUploadUrl x us = us { usUploadUrl = x } +uploadBytes :: HackageCreds + -> String -- ^ tar file name + -> L.ByteString -- ^ tar file contents + -> IO () +uploadBytes creds tarName bytes = do + let req1 = setRequestHeader "Accept" ["text/plain"] + "https://hackage.haskell.org/packages/" + formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] + req2 <- formDataBody formData req1 + req3 <- applyCreds creds req2 + putStr $ "Uploading " ++ tarName ++ "... " + hFlush stdout + withResponse req3 $ \res -> + case getResponseStatusCode res of + 200 -> putStrLn "done!" + 401 -> do + putStrLn "authentication failure" + handleIO (const $ return ()) (removeFile (hcCredsFile creds)) + throwString "Authentication failure uploading to server" + 403 -> do + putStrLn "forbidden upload" + putStrLn "Usually means: you've already uploaded this package/version combination" + putStrLn "Ignoring error and continuing, full message from Hackage below:\n" + printBody res + 503 -> do + putStrLn "service unavailable" + putStrLn "This error some times gets sent even though the upload succeeded" + putStrLn "Check on Hackage to see if your pacakge is present" + printBody res + code -> do + putStrLn $ "unhandled status code: " ++ show code + printBody res + throwString $ "Upload failed on " ++ tarName --- | How to get the Hackage credentials. --- --- Default: @fromAnywhere@ --- --- Since 0.1.0.0 -setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings -setCredsSource x us = us { usCredsSource = x } +printBody :: Response (ConduitM () S.ByteString IO ()) -> IO () +printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout --- | Save new credentials to the config file. --- --- Default: @True@ +-- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 -setSaveCreds :: Bool -> UploadSettings -> UploadSettings -setSaveCreds x us = us { usSaveCreds = x } - -handleIO :: (E.IOException -> IO a) -> IO a -> IO a -handleIO = E.handle +upload :: HackageCreds -> FilePath -> IO () +upload creds fp = uploadBytes creds (takeFileName fp) =<< L.readFile fp + +uploadRevision :: HackageCreds + -> PackageIdentifier + -> L.ByteString + -> IO () +uploadRevision creds ident cabalFile = do + req0 <- parseRequest $ concat + [ "https://hackage.haskell.org/package/" + , packageIdentifierString ident + , "/" + , packageNameString $ packageIdentifierName ident + , ".cabal/edit" + ] + req1 <- formDataBody + [ partLBS "cabalfile" cabalFile + , partBS "publish" "on" + ] + req0 + req2 <- applyCreds creds req1 + void $ httpNoBody req2 diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs index 819aa6deef..6fe0a759d6 100644 --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -18,7 +18,7 @@ module System.Process.PagerEditor ,EditorException(..)) where -import Control.Exception (try,IOException,throwIO,Exception) +import Control.Monad.IO.Unlift import Data.ByteString.Lazy (ByteString,hPut,readFile) import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder) import Data.Typeable (Typeable) diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 83d9042719..d44365a7c2 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -40,12 +40,9 @@ module System.Process.Read import Control.Applicative import Control.Arrow ((***), first) import Control.Concurrent.Async (concurrently) -import Control.Exception hiding (try, catch) -import Control.Monad (join, liftM, unless, void) -import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (join, liftM, unless) +import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) import qualified Data.ByteString as S import Data.ByteString.Builder import qualified Data.ByteString.Lazy as L @@ -148,7 +145,7 @@ envHelper = Just . eoStringList -- | Read from the process, ignoring any output. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessNull :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +readProcessNull :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional working directory -> EnvOverride -> String -- ^ Command @@ -159,7 +156,7 @@ readProcessNull wd menv name args = -- | Try to produce a strict 'S.ByteString' from the stdout of a -- process. -tryProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +tryProcessStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -170,7 +167,7 @@ tryProcessStdout wd menv name args = -- | Try to produce strict 'S.ByteString's from the stderr and stdout of a -- process. -tryProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +tryProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -182,7 +179,7 @@ tryProcessStderrStdout wd menv name args = -- | Produce a strict 'S.ByteString' from the stdout of a process. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) +readProcessStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -195,7 +192,7 @@ readProcessStdout wd menv name args = -- | Produce strict 'S.ByteString's from the stderr and stdout of a process. -- -- Throws a 'ReadProcessException' exception if the process fails. -readProcessStderrStdout :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) +readProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -249,7 +246,7 @@ instance Exception ReadProcessException -- -- Throws a 'ReadProcessException' if unsuccessful. sinkProcessStdout - :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) + :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command @@ -272,7 +269,7 @@ sinkProcessStdout wd menv name args sinkStdout = do (\(ProcessExitedUnsuccessfully cp ec) -> do stderrBuilder <- liftIO (readIORef stderrBuffer) stdoutBuilder <- liftIO (readIORef stdoutBuffer) - throwM $ ProcessFailed + liftIO $ throwM $ ProcessFailed cp ec (toLazyByteString stdoutBuilder) @@ -280,15 +277,16 @@ sinkProcessStdout wd menv name args sinkStdout = do return sinkRet logProcessStderrStdout - :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) + :: (MonadUnliftIO m, MonadLogger m) => Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m () -logProcessStderrStdout mdir name menv args = liftBaseWith $ \restore -> do - let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr) - void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines +logProcessStderrStdout mdir name menv args = withUnliftIO $ \u -> do + let logLines = CB.lines =$ CL.mapM_ (unliftIO u . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr) + ((), ()) <- unliftIO u $ sinkProcessStderrStdout mdir menv name args logLines logLines + return () -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers. -- @@ -423,11 +421,11 @@ getEnvOverride platform = mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) -newtype PathException = PathsInvalidInPath [FilePath] +newtype InvalidPathException = PathsInvalidInPath [FilePath] deriving Typeable -instance Exception PathException -instance Show PathException where +instance Exception InvalidPathException +instance Show InvalidPathException where show (PathsInvalidInPath paths) = unlines $ [ "Would need to add some paths to the PATH environment variable \ \to continue, but they would be invalid because they contain a " diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs index 36c1fc967a..7c221ea668 100644 --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -21,11 +21,9 @@ module System.Process.Run ) where -import Control.Exception.Lifted import Control.Monad (liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.IO.Unlift import Control.Monad.Logger (MonadLogger, logError) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Conduit.Process hiding (callProcess) import Data.Foldable (forM_) import Data.Text (Text) @@ -51,14 +49,14 @@ data Cmd = Cmd -- If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. runCmd :: forall (m :: * -> *). - (MonadLogger m,MonadIO m,MonadBaseControl IO m) + (MonadLogger m, MonadUnliftIO m) => Cmd -> Maybe Text -- ^ optional additional error message -> m () runCmd = runCmd' id runCmd' :: forall (m :: * -> *). - (MonadLogger m,MonadIO m,MonadBaseControl IO m) + (MonadLogger m, MonadUnliftIO m) => (CreateProcess -> CreateProcess) -> Cmd -> Maybe Text -- ^ optional additional error message @@ -105,7 +103,7 @@ callProcess' modCP cmd = do exit_code <- waitForProcess p case exit_code of ExitSuccess -> return () - ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code) + ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) callProcessInheritStderrStdout :: (MonadIO m, MonadLogger m) => Cmd -> m () callProcessInheritStderrStdout cmd = do @@ -122,7 +120,7 @@ callProcessObserveStdout cmd = do exit_code <- waitForProcess p case exit_code of ExitSuccess -> hGetLine hStdout - ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code) + ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) where modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } diff --git a/src/main/Main.hs b/src/main/Main.hs index b1d25a3c64..a19962cc9c 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -15,9 +15,8 @@ module Main (main) where #ifndef HIDE_DEP_VERSIONS import qualified Build_stack #endif -import Control.Exception import Control.Monad hiding (mapM, forM) -import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader (local) import Control.Monad.Trans.Either (EitherT) @@ -25,8 +24,9 @@ import Control.Monad.Writer.Lazy (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) import qualified Data.ByteString.Lazy as L +import Data.IORef.RunOnce (runOnce) import Data.List -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid import Data.Text (Text) @@ -55,7 +55,6 @@ import Path.IO 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 @@ -81,24 +80,26 @@ import Stack.Options.DotParser import Stack.Options.ExecParser import Stack.Options.GhciParser import Stack.Options.GlobalParser + import Stack.Options.HpcReportParser import Stack.Options.NewParser import Stack.Options.NixParser import Stack.Options.ScriptParser +import Stack.Options.SDistParser 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.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball', SDistOpts(..)) import Stack.SetupCmd import qualified Stack.Sig as Sig +import Stack.Snapshot (loadResolver) import Stack.Solver (solveExtraDeps) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Compiler -import Stack.Types.Resolver import Stack.Types.Nix import Stack.Types.StackT import Stack.Types.StringError @@ -298,26 +299,12 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions "upload" "Upload a package to Hackage" uploadCmd - ((,,,,) <$> many (strArgument $ metavar "TARBALL/DIR" <> completer fileCompleter) <*> - optional pvpBoundsOption <*> - ignoreCheckSwitch <*> - switch (long "no-signature" <> help "Do not sign & upload signatures") <*> - strOption - (long "sig-server" <> metavar "URL" <> showDefault <> - value "https://sig.commercialhaskell.org" <> - help "URL")) + (sdistOptsParser True) addCommand' "sdist" "Create source distribution tarballs" sdistCmd - ((,,,,) <$> many (strArgument $ metavar "DIR" <> completer dirCompleter) <*> - optional pvpBoundsOption <*> - ignoreCheckSwitch <*> - switch (long "sign" <> help "Sign & upload signatures") <*> - strOption - (long "sig-server" <> metavar "URL" <> showDefault <> - value "https://sig.commercialhaskell.org" <> - help "URL")) + (sdistOptsParser False) addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd @@ -446,10 +433,6 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions hpcReportOptsParser) ) where - ignoreCheckSwitch = - switch (long "ignore-check" - <> help "Do not check package for common mistakes") - -- addCommand hiding global options addCommand' :: String -> String -> (a -> GlobalOpts -> IO ()) -> Parser a -> AddCommand @@ -636,24 +619,13 @@ uninstallCmd :: [String] -> GlobalOpts -> IO () uninstallCmd _ go = withConfigAndLock go $ do $logError "stack does not manage installations in global locations" $logError "The only global mutation stack performs is executable copying" - $logError "For the default executable destination, please run 'stack path --local-bin-path'" + $logError "For the default executable destination, please run 'stack path --local-bin'" -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go = withConfigAndLock go $ do - 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 _ -> throwString "Error: unpack does not work with compiler resolvers" - ResolverCustom _ _ -> throwString "Error: unpack does not work with custom resolvers" - Stack.Fetch.unpackPackages mMiniBuildPlan "." names + mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) + Stack.Fetch.unpackPackages mSnapshotDef "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () @@ -671,72 +643,72 @@ upgradeCmd upgradeOpts' go = withGlobalConfigAndLock go $ upgradeOpts' -- | Upload to Hackage -uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () -uploadCmd ([], _, _, _, _) _ = throwString "Error: To upload the current package, please run 'stack upload .'" -uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do +uploadCmd :: SDistOpts -> GlobalOpts -> IO () +uploadCmd (SDistOpts [] _ _ _ _ _) _ = throwString "Error: To upload the current package, please run 'stack upload .'" +uploadCmd sdistOpts go = do let partitionM _ [] = return ([], []) partitionM f (x:xs) = do r <- f x (as, bs) <- partitionM f xs return $ if r then (x:as, bs) else (as, x:bs) - (files, nonFiles) <- partitionM D.doesFileExist args + (files, nonFiles) <- partitionM D.doesFileExist (sdoptsDirsToWorkWith sdistOpts) (dirs, invalid) <- partitionM D.doesDirectoryExist nonFiles unless (null invalid) $ do hPutStrLn stderr $ "Error: stack upload expects a list sdist tarballs or cabal directories. Can't find " ++ show invalid exitFailure - let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader - getUploader = do - config <- view configL - liftIO $ Upload.mkUploader config Upload.defaultUploadSettings withBuildConfigAndLock go $ \_ -> do - uploader <- getUploader - unless ignoreCheck $ - mapM_ (resolveFile' >=> checkSDistTarball) files + config <- view configL + getCreds <- liftIO (runOnce (Upload.loadCreds config)) + mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files forM_ files (\file -> do tarFile <- resolveFile' file - liftIO - (Upload.upload uploader (toFilePath tarFile)) - unless - don'tSign + liftIO $ do + creds <- getCreds + Upload.upload creds (toFilePath tarFile) + when + (sdoptsSign sdistOpts) (void $ Sig.sign - sigServerUrl + (sdoptsSignServerUrl sdistOpts) tarFile)) unless (null dirs) $ forM_ dirs $ \dir -> do pkgDir <- resolveDir' dir - (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir - unless ignoreCheck $ checkSDistTarball' tarName tarBytes - liftIO $ Upload.uploadBytes uploader tarName tarBytes + (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir + checkSDistTarball' sdistOpts tarName tarBytes + liftIO $ do + creds <- getCreds + Upload.uploadBytes creds tarName tarBytes + forM_ mcabalRevision $ uncurry $ Upload.uploadRevision creds tarPath <- parseRelFile tarName - unless - don'tSign + when + (sdoptsSign sdistOpts) (void $ Sig.signTarBytes - sigServerUrl + (sdoptsSignServerUrl sdistOpts) tarPath tarBytes) -sdistCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () -sdistCmd (dirs, mpvpBounds, ignoreCheck, sign, sigServerUrl) go = +sdistCmd :: SDistOpts -> GlobalOpts -> IO () +sdistCmd sdistOpts go = withBuildConfig go $ do -- No locking needed. -- If no directories are specified, build all sdist tarballs. - dirs' <- if null dirs - then liftM Map.keys getLocalPackages - else mapM resolveDir' dirs + dirs' <- if null (sdoptsDirsToWorkWith sdistOpts) + then liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages + else mapM resolveDir' (sdoptsDirsToWorkWith sdistOpts) forM_ dirs' $ \dir -> do - (tarName, tarBytes) <- getSDistTarball mpvpBounds dir + (tarName, tarBytes, _mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) dir distDir <- distDirFromDir dir tarPath <- (distDir ) <$> parseRelFile tarName ensureDir (parent tarPath) liftIO $ L.writeFile (toFilePath tarPath) tarBytes - unless ignoreCheck (checkSDistTarball tarPath) + checkSDistTarball sdistOpts tarPath $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) - when sign (void $ Sig.sign sigServerUrl tarPath) + when (sdoptsSign sdistOpts) (void $ Sig.sign (sdoptsSignServerUrl sdistOpts) tarPath) -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO () diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs index f796e1dd68..783dfca6ab 100644 --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -4,10 +4,10 @@ module Stack.Build.TargetSpec (main, spec) where import qualified Data.Text as T import Stack.Build.Target +import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import Stack.Types.Package import Test.Hspec main :: IO () diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs deleted file mode 100644 index a916baad7e..0000000000 --- a/src/test/Stack/BuildPlanSpec.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Stack.BuildPlanSpec where - -import Stack.BuildPlan -import Control.Monad.Logger -import Control.Exception hiding (try) -import Control.Monad.Catch (try) -import Data.Monoid -import qualified Data.Map as Map -import qualified Data.Set as Set -import Prelude -- Fix redundant import warnings -import System.Directory -import System.Environment -import System.IO.Temp (withSystemTempDirectory) -import Test.Hspec -import Stack.Config -import Stack.Types.BuildPlan -import Stack.Types.PackageName -import Stack.Types.Version -import Stack.Types.Config -import Stack.Types.Compiler -import Stack.Types.StackT - -setup :: IO () -setup = unsetEnv "STACK_YAML" - -main :: IO () -main = hspec spec - -spec :: Spec -spec = beforeAll setup $ do - let logLevel = LevelDebug - 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 - withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do - let enterDir = setCurrentDirectory tempDir - let exitDir = setCurrentDirectory currentDirectory - bracket_ enterDir exitDir action - it "finds missing transitive dependencies #159" $ inTempDir $ do - -- Note: this test is somewhat fragile, depending on packages on - -- Hackage remaining in a certain state. If it fails, confirm that - -- github still depends on failure. - writeFile "stack.yaml" "resolver: lts-2.9" - LoadConfig{..} <- loadConfig' - bconfig <- loadBuildConfigRest (lcLoadBuildConfig Nothing) - runStackT bconfig logLevel True False ColorAuto False $ do - mbp <- loadMiniBuildPlan $ LTS 2 9 - eres <- try $ resolveBuildPlan - mbp - (const False) - (Map.fromList - [ ($(mkPackageName "github"), Set.empty) - ]) - case eres of - Left (UnknownPackages _ unknown _) -> do - case Map.lookup $(mkPackageName "github") unknown of - Nothing -> error "doesn't list github as unknown" - Just _ -> return () - - {- Currently not implemented, see: https://github.com/fpco/stack/issues/159#issuecomment-107809418 - case Map.lookup $(mkPackageName "failure") unknown of - Nothing -> error "failure not listed" - Just _ -> return () - -} - _ -> error $ "Unexpected result from resolveBuildPlan: " ++ show eres - return () - - describe "shadowMiniBuildPlan" $ do - let version = $(mkVersion "1.0.0") -- unimportant for this test - pn = either throw id . parsePackageNameFromString - mkMPI deps = MiniPackageInfo - { mpiVersion = version - , mpiFlags = Map.empty - , mpiGhcOptions = [] - , mpiPackageDeps = Set.fromList $ map pn $ words deps - , mpiToolDeps = Set.empty - , mpiExes = Set.empty - , mpiHasLibrary = True - , mpiGitSHA1 = Nothing - } - go x y = (pn x, mkMPI y) - resourcet = go "resourcet" "" - conduit = go "conduit" "resourcet" - conduitExtra = go "conduit-extra" "conduit" - text = go "text" "" - attoparsec = go "attoparsec" "text" - aeson = go "aeson" "text attoparsec" - mkMBP pkgs = MiniBuildPlan - { mbpCompilerVersion = GhcVersion version - , mbpPackages = Map.fromList pkgs - } - mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson] - test name input shadowed output extra = - it name $ const $ - shadowMiniBuildPlan input (Set.fromList $ map pn $ words shadowed) - `shouldBe` (output, Map.fromList extra) - test "no shadowing" mbpAll "" mbpAll [] - test "shadow something that isn't there" mbpAll "does-not-exist" mbpAll [] - test "shadow a leaf" mbpAll "conduit-extra" - (mkMBP [resourcet, conduit, text, attoparsec, aeson]) - [] - test "shadow direct dep" mbpAll "conduit" - (mkMBP [resourcet, text, attoparsec, aeson]) - [conduitExtra] - test "shadow deep dep" mbpAll "resourcet" - (mkMBP [text, attoparsec, aeson]) - [conduit, conduitExtra] - test "shadow deep dep and leaf" mbpAll "resourcet aeson" - (mkMBP [text, attoparsec]) - [conduit, conduitExtra] - test "shadow deep dep and direct dep" mbpAll "resourcet conduit" - (mkMBP [text, attoparsec, aeson]) - [conduitExtra] diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs index 8334e05e86..d06fe434b6 100644 --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -81,7 +81,7 @@ spec = do , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1" , "ghc-prim-0.3.1.0-a24f9c14c632d75b683d0f93283aea37" ] - haskell2010 `shouldBe` DumpPackage + haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent , dpLicense = Just BSD3 @@ -95,6 +95,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = False + , dpExposedModules = [] } it "ghc 7.10" $ do @@ -121,7 +122,7 @@ spec = do , "transformers-0.4.2.0-c1a7bb855a176fe475d7b665301cd48f" , "unix-2.7.1.0-e5915eb989e568b732bc7286b0d0817f" ] - haskell2010 `shouldBe` DumpPackage + haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent , dpLicense = Just BSD3 @@ -135,6 +136,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = False + , dpExposedModules = [] } it "ghc 7.8.4 (osx)" $ do hmatrix:_ <- runResourceT @@ -172,6 +174,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = True + , dpExposedModules = ["Data.Packed","Data.Packed.Vector","Data.Packed.Matrix","Data.Packed.Foreign","Data.Packed.ST","Data.Packed.Development","Numeric.LinearAlgebra","Numeric.LinearAlgebra.LAPACK","Numeric.LinearAlgebra.Algorithms","Numeric.Container","Numeric.LinearAlgebra.Util","Numeric.LinearAlgebra.Devel","Numeric.LinearAlgebra.Data","Numeric.LinearAlgebra.HMatrix","Numeric.LinearAlgebra.Static"] } it "ghc HEAD" $ do ghcBoot:_ <- runResourceT @@ -203,6 +206,7 @@ spec = do , dpHaddock = () , dpSymbols = () , dpIsExposed = True + , dpExposedModules = ["GHC.Lexeme", "GHC.PackageDb"] } diff --git a/src/test/Stack/StoreSpec.hs b/src/test/Stack/StoreSpec.hs index dd846ec064..032daefe99 100644 --- a/src/test/Stack/StoreSpec.hs +++ b/src/test/Stack/StoreSpec.hs @@ -16,15 +16,16 @@ import Data.Int import Data.Map (Map) import Data.Sequences (fromList) import Data.Set (Set) +import Data.Store.Internal (StaticSize (..)) import Data.Store.TH import Data.Text (Text) import qualified Data.Vector.Unboxed as UV import Data.Word +import GHC.TypeLits (KnownNat) import Language.Haskell.TH import Language.Haskell.TH.ReifyMany import Prelude import Stack.Types.Build -import Stack.Types.BuildPlan import Stack.Types.PackageDump import Stack.Types.PackageIndex import Test.Hspec @@ -51,6 +52,8 @@ instance Monad m => Serial m BS.ByteString where instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where series = fmap setFromList series +instance (Monad m, KnownNat n) => Serial m (StaticSize n BS.ByteString) + addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] addMinAndMaxBounds xs = (if (minBound :: a) `notElem` xs then [minBound] else []) ++ @@ -64,7 +67,7 @@ $(do let ns = [ ''Int64, ''Word64, ''Word, ''Word8 $(do let tys = [ ''InstalledCacheInner , ''PackageCacheMap - , ''MiniBuildPlan + -- FIXME , ''LoadedSnapshot , ''BuildCache , ''ConfigCache ] @@ -85,7 +88,7 @@ spec = do -- Blows up with > 5 $(smallcheckManyStore False 5 [ [t| PackageCacheMap |] - , [t| MiniBuildPlan |] + -- FIXME , [t| LoadedSnapshot |] ]) -- Blows up with > 4 $(smallcheckManyStore False 4 diff --git a/stack-7.10.yaml b/stack-7.10.yaml index 5996529c93..bf1b9289ab 100644 --- a/stack-7.10.yaml +++ b/stack-7.10.yaml @@ -14,6 +14,8 @@ nix: flags: stack: hide-dependency-versions: true + mintty: + win32-2-5: false extra-deps: - Cabal-1.24.2.0 - th-utilities-0.2.0.1 @@ -24,7 +26,7 @@ extra-deps: - http-client-tls-0.3.4 - http-conduit-2.2.3 - optparse-applicative-0.13.0.0 -- text-metrics-0.1.0 +- text-metrics-0.3.0 - pid1-0.1.0.0 - aeson-1.0.2.1 - hpack-0.17.0 @@ -34,3 +36,5 @@ extra-deps: - cryptohash-sha256-0.11.100.1 - ed25519-0.0.5.0 - hackage-security-0.5.2.2 +- echo-0.1.3 +- mintty-0.1.1 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 9fa240aa8c..5ea2e111d1 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -6,6 +6,7 @@ image: extra-deps: - store-0.4.1 - store-core-0.4 +- text-metrics-0.3.0 nix: # --nix on the command-line to enable. enable: false diff --git a/stack.cabal b/stack.cabal index c320298da3..69ed3b3b12 100644 --- a/stack.cabal +++ b/stack.cabal @@ -64,6 +64,7 @@ library hs-source-dirs: src/ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities exposed-modules: Control.Concurrent.Execute + Control.Monad.IO.Unlift Data.Aeson.Extended Data.Attoparsec.Args Data.Attoparsec.Combinators @@ -79,6 +80,7 @@ library Options.Applicative.Args Options.Applicative.Builder.Extra Options.Applicative.Complicated + Path.CheckInstall Path.Extra Path.Find Paths_stack @@ -136,12 +138,14 @@ library Stack.Options.PackageParser Stack.Options.ResolverParser Stack.Options.ScriptParser + Stack.Options.SDistParser Stack.Options.SolverParser Stack.Options.TestParser Stack.Options.Utils Stack.Package Stack.PackageDump Stack.PackageIndex + Stack.PackageLocation Stack.Path Stack.PrettyPrint Stack.Runners @@ -153,6 +157,7 @@ library Stack.Sig Stack.Sig.GPG Stack.Sig.Sign + Stack.Snapshot Stack.Solver Stack.Types.Build Stack.Types.BuildPlan @@ -178,6 +183,7 @@ library Stack.Types.StringError Stack.Types.TemplateName Stack.Types.Version + Stack.Types.VersionIntervals Stack.Upgrade Stack.Upload Text.PrettyPrint.Leijen.Extended @@ -205,8 +211,9 @@ library , cryptonite >= 0.19 && < 0.22 , cryptonite-conduit >= 0.1 && < 0.3 , directory >= 1.2.1.0 && < 1.4 + , echo >= 0.1.3 && < 0.2 , either - , errors < 2.2 + , errors < 2.3 , exceptions >= 0.8.0.2 , extra < 1.6 , fast-logger >= 2.3.1 @@ -222,20 +229,16 @@ library , http-client-tls >= 0.3.4 , http-conduit >= 2.2.3 , http-types >= 0.8.6 && < 0.10 - , lifted-async - -- https://github.com/basvandijk/lifted-base/issues/31 - , lifted-base < 0.2.3.7 || > 0.2.3.7 , memory >= 0.13 && < 0.15 , microlens >= 0.3.0.0 , microlens-mtl - , monad-control + , mintty >= 0.1.1 , monad-logger >= 0.3.13.1 - , monad-unlift < 0.3 , mtl >= 2.1.3.1 , network-uri , open-browser >= 0.2.1 , optparse-applicative >= 0.13 && < 0.14 - , path >= 0.5.8 + , path >= 0.5.8 && <= 0.5.12 , path-io >= 1.1.0 && < 2.0.0 , persistent >= 2.1.2 && < 2.7 -- persistent-sqlite-2.5.0.1 has a bug @@ -258,7 +261,7 @@ library , temporary >= 1.2.0.3 , text >= 1.2.0.4 , text-binary - , text-metrics >= 0.1 && < 0.3 + , text-metrics >= 0.3 && < 0.4 , time >= 1.4.2 && < 1.7 , tls >= 1.3.8 , transformers >= 0.3.0.0 && < 0.6 @@ -306,10 +309,7 @@ executable stack , filepath >= 1.3.0.2 , hpack >= 0.17.0 && < 0.18 , http-client >= 0.5.3.3 - -- https://github.com/basvandijk/lifted-base/issues/31 - , lifted-base < 0.2.3.7 || > 0.2.3.7 , microlens >= 0.3.0.0 - , monad-control , monad-logger >= 0.3.13.1 , mtl >= 2.1.3.1 , optparse-applicative >= 0.13 && < 0.14 @@ -335,7 +335,6 @@ test-suite stack-test hs-source-dirs: src/test main-is: Test.hs other-modules: Spec - , Stack.BuildPlanSpec , Stack.Build.ExecuteSpec , Stack.Build.TargetSpec , Stack.ConfigSpec @@ -360,7 +359,6 @@ test-suite stack-test , containers >= 0.5.5.1 , cryptonite >= 0.19 && < 0.22 , directory >= 1.2.1.0 && < 1.4 - , exceptions , filepath , hspec >= 2.2 && <2.5 , hashable diff --git a/stack.yaml b/stack.yaml index 53efef8feb..695dce0e53 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,5 +14,9 @@ nix: flags: stack: hide-dependency-versions: true + mintty: + win32-2-5: false extra-deps: +- mintty-0.1.1 - store-0.4.1 +- text-metrics-0.3.0 diff --git a/test/integration/tests/1884-url-to-tarball/files/stack.yaml b/test/integration/tests/1884-url-to-tarball/files/stack.yaml index cfec24ef61..5e1adeeedf 100644 --- a/test/integration/tests/1884-url-to-tarball/files/stack.yaml +++ b/test/integration/tests/1884-url-to-tarball/files/stack.yaml @@ -1,4 +1,5 @@ packages: -- https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz +- location: https://hackage.haskell.org/package/half-0.2.2.3/half-0.2.2.3.tar.gz + extra-dep: false extra-deps: [] resolver: lts-8.0 diff --git a/test/integration/tests/3229-exe-targets/Main.hs b/test/integration/tests/3229-exe-targets/Main.hs new file mode 100644 index 0000000000..86e0e1df33 --- /dev/null +++ b/test/integration/tests/3229-exe-targets/Main.hs @@ -0,0 +1,41 @@ +-- | Stack should build all executables once, and in subsequent +-- invocations only build those executables requested by the program +-- arguments. +-- +-- Issue: https://github.com/commercialhaskell/stack/issues/3229 + +module Main where + +import Control.Exception +import Control.Monad (unless, when) +import qualified Data.ByteString as S +import Data.List (isInfixOf) +import StackTest + +main :: IO () +main = do + stack [defaultResolverArg, "clean", "--full"] + stack [defaultResolverArg, "init", "--force"] + stack ["build", ":alpha"] + bracket + (S.readFile alphaFile) + (S.writeFile alphaFile) + (const + (do appendFile alphaFile "\n--" + stackCheckStderr + ["build", ":alpha"] + (rejectMessage + (unlines + ["Preprocessing executable 'beta' for foo-0..."])))) + where + alphaFile = "app/Alpha.hs" + +expectMessage :: String -> String -> IO () +expectMessage msg stderr = + unless (msg `isInfixOf` stderr) + (error $ "Expected in output: \n" ++ show msg) + +rejectMessage :: String -> String -> IO () +rejectMessage msg stderr = + when (msg `isInfixOf` stderr) + (error $ "Did not expect message here: \n" ++ show msg) diff --git a/test/integration/tests/3229-exe-targets/files/app/Alpha.hs b/test/integration/tests/3229-exe-targets/files/app/Alpha.hs new file mode 100644 index 0000000000..b3549c2fe3 --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/app/Alpha.hs @@ -0,0 +1 @@ +main = return () diff --git a/test/integration/tests/3229-exe-targets/files/app/Beta.hs b/test/integration/tests/3229-exe-targets/files/app/Beta.hs new file mode 100644 index 0000000000..b3549c2fe3 --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/app/Beta.hs @@ -0,0 +1 @@ +main = return () diff --git a/test/integration/tests/3229-exe-targets/files/foo.cabal b/test/integration/tests/3229-exe-targets/files/foo.cabal new file mode 100644 index 0000000000..4a68648e6d --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/foo.cabal @@ -0,0 +1,22 @@ +name: foo +version: 0 +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Foo + build-depends: base >= 4.7 && < 5 + default-language: Haskell2010 + +executable alpha + hs-source-dirs: app + main-is: Alpha.hs + build-depends: base, foo + default-language: Haskell2010 + +executable beta + hs-source-dirs: app + main-is: Beta.hs + build-depends: base, foo + default-language: Haskell2010 diff --git a/test/integration/tests/3229-exe-targets/files/src/Foo.hs b/test/integration/tests/3229-exe-targets/files/src/Foo.hs new file mode 100644 index 0000000000..efbf93bbde --- /dev/null +++ b/test/integration/tests/3229-exe-targets/files/src/Foo.hs @@ -0,0 +1 @@ +module Foo where diff --git a/test/integration/tests/717-sdist-test/Main.hs b/test/integration/tests/717-sdist-test/Main.hs new file mode 100644 index 0000000000..cce419b2a5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/Main.hs @@ -0,0 +1,19 @@ +import StackTest + +main :: IO () +main = do + -- verify building works + stack ["build"] + -- keep old behavior + stack ["sdist"] + -- successful sdist with --test-tarball + stack ["sdist", "package-with-working-th", "--test-tarball"] + -- fails because package contains TH which depends on files which are not put into sdist tarball + stackErr ["sdist", "package-with-th", "--test-tarball"] + -- same, but inside a subdir + stackErr ["sdist", "subdirs/failing-in-subdir", "--test-tarball"] + -- depends on packagea and packagec - these would fail if they were the target of sdist, + -- but since they are just dependencies, the operation should succeed + stack ["sdist", "subdirs/dependent-on-failing-packages", "--test-tarball"] + -- fails because a test depends on files which are not put into sdist tarball + stackErr ["sdist", "package-with-failing-test", "--test-tarball"] diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/LICENSE b/test/integration/tests/717-sdist-test/files/package-with-failing-test/LICENSE new file mode 100644 index 0000000000..6a042c2ad5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/README.md b/test/integration/tests/717-sdist-test/files/package-with-failing-test/README.md new file mode 100644 index 0000000000..8831e9c09c --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/README.md @@ -0,0 +1 @@ +# thtest diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/Setup.hs b/test/integration/tests/717-sdist-test/files/package-with-failing-test/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/files/file.txt b/test/integration/tests/717-sdist-test/files/package-with-failing-test/files/file.txt new file mode 100644 index 0000000000..72943a16fb --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/files/file.txt @@ -0,0 +1 @@ +aaa diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/package-with-failing-test.cabal b/test/integration/tests/717-sdist-test/files/package-with-failing-test/package-with-failing-test.cabal new file mode 100644 index 0000000000..9cb5a0ead5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/package-with-failing-test.cabal @@ -0,0 +1,27 @@ +name: package-with-failing-test +version: 0.1.0.0 +synopsis: Some package +description: Some package +homepage: https://invalid +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + build-depends: base >= 4.7 && < 5, + template-haskell + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: base >= 4.7 && < 5 diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/src/Lib.hs b/test/integration/tests/717-sdist-test/files/package-with-failing-test/src/Lib.hs new file mode 100644 index 0000000000..0d8704c625 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/src/Lib.hs @@ -0,0 +1,8 @@ +module Lib + ( someFunc + ) where + +import Language.Haskell.TH + +someFunc :: IO () +someFunc = putStrLn "aaa" diff --git a/test/integration/tests/717-sdist-test/files/package-with-failing-test/test/Test.hs b/test/integration/tests/717-sdist-test/files/package-with-failing-test/test/Test.hs new file mode 100644 index 0000000000..39a26a86b4 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-failing-test/test/Test.hs @@ -0,0 +1,4 @@ +main :: IO () +main = do + readFile "files/file.txt" + return () diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/LICENSE b/test/integration/tests/717-sdist-test/files/package-with-th/LICENSE new file mode 100644 index 0000000000..6a042c2ad5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/README.md b/test/integration/tests/717-sdist-test/files/package-with-th/README.md new file mode 100644 index 0000000000..8831e9c09c --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/README.md @@ -0,0 +1 @@ +# thtest diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/Setup.hs b/test/integration/tests/717-sdist-test/files/package-with-th/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/files/file.txt b/test/integration/tests/717-sdist-test/files/package-with-th/files/file.txt new file mode 100644 index 0000000000..72943a16fb --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/files/file.txt @@ -0,0 +1 @@ +aaa diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/package-with-th.cabal b/test/integration/tests/717-sdist-test/files/package-with-th/package-with-th.cabal new file mode 100644 index 0000000000..c429cc5df4 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/package-with-th.cabal @@ -0,0 +1,22 @@ +name: package-with-th +version: 0.1.0.0 +synopsis: Some package +description: Some package +homepage: https://invalid +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib, + TH + build-depends: base >= 4.7 && < 5, + template-haskell + default-language: Haskell2010 diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/src/Lib.hs b/test/integration/tests/717-sdist-test/files/package-with-th/src/Lib.hs new file mode 100644 index 0000000000..26d2841b8f --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/src/Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib + ( someFunc + ) where + +import TH +import Language.Haskell.TH + +someFunc :: IO () +someFunc = print $(thFunc) diff --git a/test/integration/tests/717-sdist-test/files/package-with-th/src/TH.hs b/test/integration/tests/717-sdist-test/files/package-with-th/src/TH.hs new file mode 100644 index 0000000000..df44b9d8ae --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-th/src/TH.hs @@ -0,0 +1,8 @@ +module TH (thFunc) where + +import Language.Haskell.TH + +thFunc :: Q Exp +thFunc = runIO $ do + readFile "files/file.txt" + return $ LitE (IntegerL 5) diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/LICENSE b/test/integration/tests/717-sdist-test/files/package-with-working-th/LICENSE new file mode 100644 index 0000000000..6a042c2ad5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/README.md b/test/integration/tests/717-sdist-test/files/package-with-working-th/README.md new file mode 100644 index 0000000000..8831e9c09c --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/README.md @@ -0,0 +1 @@ +# thtest diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/Setup.hs b/test/integration/tests/717-sdist-test/files/package-with-working-th/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/files/file.txt b/test/integration/tests/717-sdist-test/files/package-with-working-th/files/file.txt new file mode 100644 index 0000000000..72943a16fb --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/files/file.txt @@ -0,0 +1 @@ +aaa diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/package-with-working-th.cabal b/test/integration/tests/717-sdist-test/files/package-with-working-th/package-with-working-th.cabal new file mode 100644 index 0000000000..dcf6b414da --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/package-with-working-th.cabal @@ -0,0 +1,22 @@ +name: package-with-working-th +version: 0.1.0.0 +synopsis: Some package +description: Some package +homepage: https://invalid +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib, + TH + build-depends: base >= 4.7 && < 5, + template-haskell + default-language: Haskell2010 diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/src/Lib.hs b/test/integration/tests/717-sdist-test/files/package-with-working-th/src/Lib.hs new file mode 100644 index 0000000000..26d2841b8f --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/src/Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Lib + ( someFunc + ) where + +import TH +import Language.Haskell.TH + +someFunc :: IO () +someFunc = print $(thFunc) diff --git a/test/integration/tests/717-sdist-test/files/package-with-working-th/src/TH.hs b/test/integration/tests/717-sdist-test/files/package-with-working-th/src/TH.hs new file mode 100644 index 0000000000..5f13e7814a --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/package-with-working-th/src/TH.hs @@ -0,0 +1,7 @@ +module TH (thFunc) where + +import Language.Haskell.TH + +thFunc :: Q Exp +thFunc = + return $ LitE (IntegerL 5) diff --git a/test/integration/tests/717-sdist-test/files/stack.yaml b/test/integration/tests/717-sdist-test/files/stack.yaml new file mode 100644 index 0000000000..2bdfa83cab --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/stack.yaml @@ -0,0 +1,12 @@ +resolver: lts-8.15 +packages: +- package-with-th +- package-with-working-th +- package-with-failing-test +- location: subdirs + subdirs: + - dependent-on-failing-packages + - failing-in-subdir +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/LICENSE b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/LICENSE new file mode 100644 index 0000000000..6a042c2ad5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/README.md b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/README.md new file mode 100644 index 0000000000..8831e9c09c --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/README.md @@ -0,0 +1 @@ +# thtest diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/Setup.hs b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/dependent-on-failing-packages.cabal b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/dependent-on-failing-packages.cabal new file mode 100644 index 0000000000..ec609d4207 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/dependent-on-failing-packages.cabal @@ -0,0 +1,23 @@ +name: dependent-on-failing-packages +version: 0.1.0.0 +synopsis: Some package +description: Some package +homepage: https://invalid +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: LibD + build-depends: base >= 4.7 && < 5, + template-haskell, + package-with-th, + failing-in-subdir + default-language: Haskell2010 diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/files/file.txt b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/files/file.txt new file mode 100644 index 0000000000..72943a16fb --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/files/file.txt @@ -0,0 +1 @@ +aaa diff --git a/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/src/LibD.hs b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/src/LibD.hs new file mode 100644 index 0000000000..a0c7ad615e --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/dependent-on-failing-packages/src/LibD.hs @@ -0,0 +1,11 @@ +module LibD + ( someFunc + ) where + +import Lib +import LibC + +someFuncD :: IO () +someFuncD = do + someFunc + someFuncC diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/LICENSE b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/LICENSE new file mode 100644 index 0000000000..6a042c2ad5 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/README.md b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/README.md new file mode 100644 index 0000000000..8831e9c09c --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/README.md @@ -0,0 +1 @@ +# thtest diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/Setup.hs b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/failing-in-subdir.cabal b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/failing-in-subdir.cabal new file mode 100644 index 0000000000..7a34fb0f28 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/failing-in-subdir.cabal @@ -0,0 +1,22 @@ +name: failing-in-subdir +version: 0.1.0.0 +synopsis: Some package +description: Some package +homepage: https://invalid +license: BSD3 +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2017 Author name here +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: LibC, + THInSubdir + build-depends: base >= 4.7 && < 5, + template-haskell + default-language: Haskell2010 diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/files/file.txt b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/files/file.txt new file mode 100644 index 0000000000..72943a16fb --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/files/file.txt @@ -0,0 +1 @@ +aaa diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/LibC.hs b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/LibC.hs new file mode 100644 index 0000000000..f951ce4a28 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/LibC.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module LibC + ( someFuncC + ) where + +import THInSubdir +import Language.Haskell.TH + +someFuncC :: IO () +someFuncC = print $(thFuncC) diff --git a/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/THInSubdir.hs b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/THInSubdir.hs new file mode 100644 index 0000000000..d5c2609120 --- /dev/null +++ b/test/integration/tests/717-sdist-test/files/subdirs/failing-in-subdir/src/THInSubdir.hs @@ -0,0 +1,8 @@ +module THInSubdir (thFuncC) where + +import Language.Haskell.TH + +thFuncC :: Q Exp +thFuncC = runIO $ do + readFile "files/file.txt" + return $ LitE (IntegerL 5) diff --git a/test/integration/tests/cyclic-test-deps/Main.hs b/test/integration/tests/cyclic-test-deps/Main.hs index 5508f741bd..1f584391f4 100644 --- a/test/integration/tests/cyclic-test-deps/Main.hs +++ b/test/integration/tests/cyclic-test-deps/Main.hs @@ -4,4 +4,6 @@ main :: IO () main = do stack ["unpack", "text-1.2.2.1"] stack ["init", defaultResolverArg] + appendFile "stack.yaml" "\n\nextra-deps:\n- test-framework-quickcheck2-0.3.0.3@sha256:989f988d0c4356d7fc1d87c062904d02eba0637c5adba428b349aeb709d81bc0" + readFile "stack.yaml" >>= putStrLn stack ["test", "--dry-run"]