diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -135,7 +135,7 @@ Running the integration tests is a little involved, you'll need to: ```bash -$ stack test stack:integration-test --flag stack:stack-integration-tests +$ stack test stack:stack-integration-test --flag stack:integration-tests ``` Running an individual module works like this: @@ -159,3 +159,12 @@ Where again, `` is the name of the folder listed in the [test/integration/tests/](https://github.com/commercialhaskell/stack/tree/master/test/integration/tests) folder. + + +## Slack channel + +If you're making deep changes and real-time communcation with the Stack team +would be helpful, we have a `#stack-collaborators` Slack channel. Please +contact [@borsboom](https://github.com/borsboom) (manny@fpcomplete.com) or +[@snoyberg](https://github.com/snoyberg) (michael@fpcomplete.com) for an +invite. diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,12 +1,106 @@ # Changelog +## v1.7.1 + +Release notes: + +* aarch64 (64-bit ARM) bindists are now available for the first time. +* Statically linked Linux bindists are no longer available, due to difficulty with GHC 8.2.2 on Alpine Linux. +* 32-bit Linux GMP4 bindists for CentOS 6 are no longer available, since GHC 8.2.2 is no longer being built for that platform. + +Major changes: + +* Upgrade from Cabal 2.0 to Cabal 2.2 + +Behavior changes: + +* `stack setup` no longer uses different GHC configure options on Linux + distributions that use GCC with PIE enabled by default. GHC detects + this itself since ghc-8.0.2, and Stack's attempted workaround for older + versions caused more problems than it solved. +* `stack new` no longer initializes a project if the project template contains + a stack.yaml file. + +Other enhancements: + +* A new sub command `ls` has been introduced to stack to view + local and remote snapshots present in the system. Use `stack ls + snapshots --help` to get more details about it. +* `list-dependencies` has been deprecated. The functionality has + to accessed through the new `ls dependencies` interface. See + [#3669](https://github.com/commercialhaskell/stack/issues/3669) + for details. +* Specify User-Agent HTTP request header on every HTTP request. + See [#3628](https://github.com/commercialhaskell/stack/issues/3628) for details. +* `stack setup` looks for GHC bindists and installations by any OS key + that is compatible (rather than only checking a single one). This is + relevant on Linux where different distributions may have different + combinations of libtinfo 5/6, ncurses 5/6, and gmp 4/5, and will allow + simpifying the setup-info metadata YAML for future GHC releases. +* The build progress bar reports names of packages currently building. +* `stack setup --verbose` causes verbose output of GHC configure process. + See [#3716](https://github.com/commercialhaskell/stack/issues/3716) +* Improve the error message when an `extra-dep` from a path or git reference can't be found + See [#3808](https://github.com/commercialhaskell/stack/pull/3808) +* Nix integration is now disabled on windows even if explicitly enabled, + since it isn't supported. See + [#3600](https://github.com/commercialhaskell/stack/issues/3600) +* `stack build` now supports a new flag `--keep-tmp-files` to retain intermediate + files and directories for the purpose of debugging. + It is best used with ghc's equivalent flag, + i.e. `stack build --keep-tmp-files --ghc-options=-keep-tmp-files`. + See [#3857](https://github.com/commercialhaskell/stack/issues/3857) +* Improved error messages for snapshot parse exceptions +* `stack unpack` now supports a `--to /target/directory` option to + specify where to unpack the package into +* `stack hoogle` now supports a new flag `--server` that launches local + Hoogle server on port 8080. See + [#2310](https://github.com/commercialhaskell/stack/issues/2310) + +Bug fixes: + +* The script interpreter's implicit file arguments are now passed before other + arguments. See [#3658](https://github.com/commercialhaskell/stack/issues/3658). + In particular, this makes it possible to pass `-- +RTS ... -RTS` to specify + RTS arguments used when running the script. +* Don't ignore the template `year` parameter in config files, and clarify the + surrounding documentation. See + [#2275](https://github.com/commercialhaskell/stack/issues/2275). +* Benchmarks used to be run concurrently with other benchmarks + and build steps. This is non-ideal because CPU usage of other processes + may interfere with benchmarks. It also prevented benchmark output from + being displayed by default. This is now fixed. See + [#3663](https://github.com/commercialhaskell/stack/issues/3663). +* `stack ghci` now allows loading multiple packages with the same + module name, as long as they have the same filepath. See + [#3776](https://github.com/commercialhaskell/stack/pull/3776). +* `stack ghci` no longer always adds a dependency on `base`. It is + now only added when there are no local targets. This allows it to + be to load code that uses replacements for `base`. See + [#3589](https://github.com/commercialhaskell/stack/issues/3589#issuecomment) +* `stack ghci` now uses correct paths for autogen files with + [#3791](https://github.com/commercialhaskell/stack/issues/3791) +* When a package contained sublibraries, stack was always recompiling the + package. This has been fixed now, no recompilation is being done because of + sublibraries. See [#3899](https://github.com/commercialhaskell/stack/issues/3899). +* The `get-stack.sh` install script now matches manual instructions + when it comes to Debian/Fedora/CentOS install dependencies. +* Compile Cabal-simple with gmp when using Nix. + See [#2944](https://github.com/commercialhaskell/stack/issues/2944) +* `stack ghci` now replaces the stack process with ghci. This improves + signal handling behavior. In particular, handling of Ctrl-C. To make + this possible, the generated files are now left behind after exit. + The paths are based on hashing file contents, and it's stored in the + system temporary directory, so this shouldn't result in too much + garbage. See + [#3821](https://github.com/commercialhaskell/stack/issues/3821). + + ## v1.6.5 Bug fixes: -* 1.6.1 introduced a change that made some precompiled cache files use - longer paths, sometimes causing builds to fail on windows. This has been - fixed. See [#3649](https://github.com/commercialhaskell/stack/issues/3649) + * Some unnecessary rebuilds when no files were changed are now avoided, by having a separate build cache for each component of a package. See [#3732](https://github.com/commercialhaskell/stack/issues/3732). @@ -111,7 +205,7 @@ * Stack will ask before saving hackage credentials to file. This new prompt can be avoided by using the `save-hackage-creds` setting. Please see [#2159](https://github.com/commercialhaskell/stack/issues/2159). -* The `GHCRTS` environment variable will no longer be passed through to +* The `GHCRTS` environment variable will no longer be passed through to every program stack runs. Instead, it will only be passed through commands like `exec`, `runghc`, `script`, `ghci`, etc. See [#3444](https://github.com/commercialhaskell/stack/issues/3444). @@ -693,7 +787,7 @@ version 1.1.2 for now on those architectures. This will be rectified soon! * We are now releasing a - [statically linked Stack binary for 64-bit Linux](https://www.stackage.org/stack/linux-x86_64-static). + [statically linked Stack binary for 64-bit Linux](https://get.haskellstack.org/stable/linux-x86_64-static.tar.gz). Please try it and let us know if you run into any trouble on your platform. * We are planning some changes to our Linux releases, including dropping our diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2017, Stack contributors +Copyright (c) 2015-2018, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,5 +6,5 @@ Stack is a cross-platform program for developing Haskell projects. It is intended for Haskellers both new and experienced. -See [haskellstack.org](http://haskellstack.org) or the `doc` directory for more +See [haskellstack.org](http://haskellstack.org) or the [doc](./doc) directory for more information. diff --git a/doc/CONTRIBUTING.md b/doc/CONTRIBUTING.md --- a/doc/CONTRIBUTING.md +++ b/doc/CONTRIBUTING.md @@ -135,7 +135,7 @@ Running the integration tests is a little involved, you'll need to: ```bash -$ stack test stack:integration-test --flag stack:stack-integration-tests +$ stack test stack:stack-integration-test --flag stack:integration-tests ``` Running an individual module works like this: @@ -159,3 +159,12 @@ Where again, `` is the name of the folder listed in the [test/integration/tests/](https://github.com/commercialhaskell/stack/tree/master/test/integration/tests) folder. + + +## Slack channel + +If you're making deep changes and real-time communcation with the Stack team +would be helpful, we have a `#stack-collaborators` Slack channel. Please +contact [@borsboom](https://github.com/borsboom) (manny@fpcomplete.com) or +[@snoyberg](https://github.com/snoyberg) (michael@fpcomplete.com) for an +invite. diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -1,12 +1,106 @@ # Changelog +## v1.7.1 + +Release notes: + +* aarch64 (64-bit ARM) bindists are now available for the first time. +* Statically linked Linux bindists are no longer available, due to difficulty with GHC 8.2.2 on Alpine Linux. +* 32-bit Linux GMP4 bindists for CentOS 6 are no longer available, since GHC 8.2.2 is no longer being built for that platform. + +Major changes: + +* Upgrade from Cabal 2.0 to Cabal 2.2 + +Behavior changes: + +* `stack setup` no longer uses different GHC configure options on Linux + distributions that use GCC with PIE enabled by default. GHC detects + this itself since ghc-8.0.2, and Stack's attempted workaround for older + versions caused more problems than it solved. +* `stack new` no longer initializes a project if the project template contains + a stack.yaml file. + +Other enhancements: + +* A new sub command `ls` has been introduced to stack to view + local and remote snapshots present in the system. Use `stack ls + snapshots --help` to get more details about it. +* `list-dependencies` has been deprecated. The functionality has + to accessed through the new `ls dependencies` interface. See + [#3669](https://github.com/commercialhaskell/stack/issues/3669) + for details. +* Specify User-Agent HTTP request header on every HTTP request. + See [#3628](https://github.com/commercialhaskell/stack/issues/3628) for details. +* `stack setup` looks for GHC bindists and installations by any OS key + that is compatible (rather than only checking a single one). This is + relevant on Linux where different distributions may have different + combinations of libtinfo 5/6, ncurses 5/6, and gmp 4/5, and will allow + simpifying the setup-info metadata YAML for future GHC releases. +* The build progress bar reports names of packages currently building. +* `stack setup --verbose` causes verbose output of GHC configure process. + See [#3716](https://github.com/commercialhaskell/stack/issues/3716) +* Improve the error message when an `extra-dep` from a path or git reference can't be found + See [#3808](https://github.com/commercialhaskell/stack/pull/3808) +* Nix integration is now disabled on windows even if explicitly enabled, + since it isn't supported. See + [#3600](https://github.com/commercialhaskell/stack/issues/3600) +* `stack build` now supports a new flag `--keep-tmp-files` to retain intermediate + files and directories for the purpose of debugging. + It is best used with ghc's equivalent flag, + i.e. `stack build --keep-tmp-files --ghc-options=-keep-tmp-files`. + See [#3857](https://github.com/commercialhaskell/stack/issues/3857) +* Improved error messages for snapshot parse exceptions +* `stack unpack` now supports a `--to /target/directory` option to + specify where to unpack the package into +* `stack hoogle` now supports a new flag `--server` that launches local + Hoogle server on port 8080. See + [#2310](https://github.com/commercialhaskell/stack/issues/2310) + +Bug fixes: + +* The script interpreter's implicit file arguments are now passed before other + arguments. See [#3658](https://github.com/commercialhaskell/stack/issues/3658). + In particular, this makes it possible to pass `-- +RTS ... -RTS` to specify + RTS arguments used when running the script. +* Don't ignore the template `year` parameter in config files, and clarify the + surrounding documentation. See + [#2275](https://github.com/commercialhaskell/stack/issues/2275). +* Benchmarks used to be run concurrently with other benchmarks + and build steps. This is non-ideal because CPU usage of other processes + may interfere with benchmarks. It also prevented benchmark output from + being displayed by default. This is now fixed. See + [#3663](https://github.com/commercialhaskell/stack/issues/3663). +* `stack ghci` now allows loading multiple packages with the same + module name, as long as they have the same filepath. See + [#3776](https://github.com/commercialhaskell/stack/pull/3776). +* `stack ghci` no longer always adds a dependency on `base`. It is + now only added when there are no local targets. This allows it to + be to load code that uses replacements for `base`. See + [#3589](https://github.com/commercialhaskell/stack/issues/3589#issuecomment) +* `stack ghci` now uses correct paths for autogen files with + [#3791](https://github.com/commercialhaskell/stack/issues/3791) +* When a package contained sublibraries, stack was always recompiling the + package. This has been fixed now, no recompilation is being done because of + sublibraries. See [#3899](https://github.com/commercialhaskell/stack/issues/3899). +* The `get-stack.sh` install script now matches manual instructions + when it comes to Debian/Fedora/CentOS install dependencies. +* Compile Cabal-simple with gmp when using Nix. + See [#2944](https://github.com/commercialhaskell/stack/issues/2944) +* `stack ghci` now replaces the stack process with ghci. This improves + signal handling behavior. In particular, handling of Ctrl-C. To make + this possible, the generated files are now left behind after exit. + The paths are based on hashing file contents, and it's stored in the + system temporary directory, so this shouldn't result in too much + garbage. See + [#3821](https://github.com/commercialhaskell/stack/issues/3821). + + ## v1.6.5 Bug fixes: -* 1.6.1 introduced a change that made some precompiled cache files use - longer paths, sometimes causing builds to fail on windows. This has been - fixed. See [#3649](https://github.com/commercialhaskell/stack/issues/3649) + * Some unnecessary rebuilds when no files were changed are now avoided, by having a separate build cache for each component of a package. See [#3732](https://github.com/commercialhaskell/stack/issues/3732). @@ -111,7 +205,7 @@ * Stack will ask before saving hackage credentials to file. This new prompt can be avoided by using the `save-hackage-creds` setting. Please see [#2159](https://github.com/commercialhaskell/stack/issues/2159). -* The `GHCRTS` environment variable will no longer be passed through to +* The `GHCRTS` environment variable will no longer be passed through to every program stack runs. Instead, it will only be passed through commands like `exec`, `runghc`, `script`, `ghci`, etc. See [#3444](https://github.com/commercialhaskell/stack/issues/3444). @@ -693,7 +787,7 @@ version 1.1.2 for now on those architectures. This will be rectified soon! * We are now releasing a - [statically linked Stack binary for 64-bit Linux](https://www.stackage.org/stack/linux-x86_64-static). + [statically linked Stack binary for 64-bit Linux](https://get.haskellstack.org/stable/linux-x86_64-static.tar.gz). Please try it and let us know if you run into any trouble on your platform. * We are planning some changes to our Linux releases, including dropping our diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -427,7 +427,7 @@ also known as *snapshots*. We mentioned the LTS resolvers, and you can get quite a bit of information about it at [https://www.stackage.org/lts](https://www.stackage.org/lts), including: -* The appropriate resolver value (`resolver: lts-10.0`, as is currently the latest LTS) +* The appropriate resolver value (`resolver: lts-11.6`, as is currently the latest LTS) * The GHC version used * A full list of all packages available in this snapshot * The ability to perform a Hoogle search on the packages in this snapshot @@ -444,7 +444,7 @@ ## Resolvers and changing your compiler version -Let's explore package sets a bit further. Instead of lts-10.0, let's change our +Let's explore package sets a bit further. Instead of lts-11.6, let's change our `stack.yaml` file to use [the latest nightly](https://www.stackage.org/nightly). Right now, this is currently 2017-12-19 - please see the resolve from the link above to get the latest. @@ -460,8 +460,8 @@ Continuous Integration (CI) setting, like on Travis. For example: ``` -michael@d30748af6d3d:~/helloworld$ stack --resolver lts-9.18 build -Downloaded lts-9.18 build plan. +michael@d30748af6d3d:~/helloworld$ stack --resolver lts-11.6 build +Downloaded lts-11.6 build plan. # build output ... ``` @@ -482,7 +482,7 @@ snapshot: ``` -michael@d30748af6d3d:~/helloworld$ stack --resolver lts-9 build +michael@d30748af6d3d:~/helloworld$ stack --resolver lts-2 build # build output ... ``` @@ -517,6 +517,15 @@ cueball:~$ cd yackage-0.8.0/ ``` +Note that you can also unpack to the directory of your liking instead of +the current one by issueing: + +``` +cueball:~$ stack unpack yackage-0.8.0 --to ~/work +``` + +This will create a `yackage-0.8.0` directory inside `~/work` + ### stack init This new directory does not have a `stack.yaml` file, so we need to make one first. We could do it by hand, but let's be lazy instead with the `stack init` @@ -1715,7 +1724,8 @@ upstream packages available). * `stack unpack` is a command we've already used quite a bit for examples, but most users won't use it regularly. It does what you'd expect: downloads a - tarball and unpacks it. + tarball and unpacks it. It accept optional `--to` argument to specify + the destination directory. * `stack sdist` generates an uploading tarball containing your package code * `stack upload` uploads an sdist to Hackage. As of version [1.1.0](https://docs.haskellstack.org/en/v1.1.0/ChangeLog/) stack @@ -1730,7 +1740,11 @@ library, used for performing actual builds. You shouldn't generally do this, since new Cabal versions may introduce incompatibilities with package sets, but it can be useful if you're trying to test a specific bugfix. -* `stack list-dependencies` lists all of the packages and versions used for a +* `stack ls snapshots` will list all the local snapshots by + default. You can also view the remote snapshots using `stack ls + snapshots remote`. It also supports option for viewing only lts + (`-l`) and nightly (`-n`) snapshots. +* `stack ls dependencies` lists all of the packages and versions used for a project * `stack sig` subcommand can help you with GPG signing & verification * `sign` will sign an sdist tarball and submit the signature to diff --git a/doc/README.md b/doc/README.md --- a/doc/README.md +++ b/doc/README.md @@ -26,7 +26,7 @@ wget -qO- https://get.haskellstack.org/ | sh On Windows, you can download and install the -[Windows 64-bit Installer](https://www.stackage.org/stack/windows-x86_64-installer). +[Windows 64-bit Installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe). For detailed instructions and downloads, including many additional operating systems, check out the diff --git a/doc/install_and_upgrade.md b/doc/install_and_upgrade.md --- a/doc/install_and_upgrade.md +++ b/doc/install_and_upgrade.md @@ -14,23 +14,22 @@ [Fedora](#fedora), [Arch Linux](#arch-linux) and [FreeBSD](#freebsd). Binaries for other operating systems are listed below, and available on -[the Github releases page](https://github.com/fpco/stack/releases). For the +[the GitHub release page](https://github.com/fpco/stack/releases). For the future, we are open to supporting more OSes (to request one, please [submit an issue](https://github.com/commercialhaskell/stack/issues/new)). Binary packages are signed with this [signing key](SIGNING_KEY.md). If you are writing a script that needs to download the latest binary, you can -find links that always point to the latest bindists -[here](https://www.stackage.org/stack). +use URLs like `https://get.haskellstack.org/stable/.` (e.g. //get.haskellstack.org/stable/linux-x86_64.tar.gz) that always point to the latest stable release. ## Windows We recommend installing to the default location with these installers, as that will make `stack install` and `stack upgrade` work correctly out of the box. - * [Windows 64-bit Installer](https://www.stackage.org/stack/windows-x86_64-installer) - * [Windows 32-bit Installer](https://www.stackage.org/stack/windows-i386-installer) + * [Windows 64-bit Installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe) + * [Windows 32-bit Installer](https://get.haskellstack.org/stable/windows-i386-installer.exe) If in doubt: you should prefer the 64-bit installer. @@ -42,8 +41,8 @@ * Download the latest release: - * [Windows 64-bit](https://www.stackage.org/stack/windows-x86_64) - * [Windows 32-bit](https://www.stackage.org/stack/windows-i386) + * [Windows 64-bit](https://get.haskellstack.org/stable/windows-x86_64.zip) + * [Windows 32-bit](https://get.haskellstack.org/stable/windows-i386.zip) * Unpack the archive and place `stack.exe` somewhere on your `%PATH%` (see [Path section below](#path)) and you can then run `stack` on the command line. @@ -65,7 +64,7 @@ ### Manual download * Download the latest release: - * [macOS 64-bit](https://www.stackage.org/stack/osx-x86_64) + * [macOS 64-bit](https://get.haskellstack.org/stable/osx-x86_64.tar.gz) * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) * Now you can run `stack` from the terminal. @@ -106,7 +105,7 @@ package](http://packages.ubuntu.com/search?keywords=haskell-stack&searchon=names&suite=all§ion=all) for Ubuntu 16.10 and up, but the distribution's Stack version lags behind, so we recommend running `stack upgrade --binary` after installing it. For older stack -versions which do not support `--binary`, just `stack upgrade` is fine too. The +versions which do not support `--binary`, just `stack upgrade` may work too. The version in Ubuntu 16.04 is too old to upgrade successfully, and so in that case stack should be installed from a [release tarball](https://github.com/commercialhaskell/stack/releases). @@ -119,7 +118,7 @@ package](https://packages.debian.org/search?keywords=haskell-stack&searchon=names&suite=all§ion=all) for Stretch and up, but the distribution's Stack version lags behind, so running `stack upgrade --binary` is recommended after installing it. For older stack -versions which do not support `--binary`, just `stack upgrade` is fine too. +versions which do not support `--binary`, just `stack upgrade` may work too. ## CentOS / Red Hat / Amazon Linux @@ -175,7 +174,7 @@ sudo pacman -S stack Note that this version may slightly lag behind, but it should be updated within -the day. The package is also always rebuilt and updated when one of it's +the day. The package is also always rebuilt and updated when one of its dependencies gets an update. - [stack](https://www.archlinux.org/packages/community/x86_64/stack/) _latest stable version_ @@ -233,14 +232,22 @@ * Download the latest release: - * [Linux 64-bit, static](https://www.stackage.org/stack/linux-x86_64-static) + * [Linux 64-bit, standard](https://get.haskellstack.org/stable/linux-x86_64.tar.gz) - * [Linux 32-bit, standard](https://www.stackage.org/stack/linux-i386) + * [Linux 64-bit, libgmp4](https://get.haskellstack.org/stable/linux-x86_64-gmp4.tar.gz) + (if you are on an older 64-bit distribution that only includes libgmp4 + (libgmp.so.3), such as CentOS/RHEL/Amazon Linux 6.) - * [Linux 32-bit, libgmp4](https://www.stackage.org/stack/linux-i386-gmp4) + * [Linux 32-bit, standard](https://get.haskellstack.org/stable/linux-i386.tar.gz) + + * [Linux 32-bit, libgmp4](https://get.haskellstack.org/stable/linux-i386-gmp4.tar.gz) (if you are on an older 32-bit distribution that only includes libgmp4 (libgmp.so.3), such as CentOS/RHEL/Amazon Linux 6.) + * [Linux ARMv7](https://get.haskellstack.org/stable/linux-arm.tar.gz) + + * [Linux AArch64](https://get.haskellstack.org/stable/linux-aarch64.tar.gz) + * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) * Ensure you have required system dependencies installed. These include GCC, GNU make, xz, perl, libgmp, libffi, and zlib. We also recommend Git and GPG. To install these using your package manager: @@ -279,7 +286,7 @@ * Download the latest release: - * [FreeBSD 64-bit](https://www.stackage.org/stack/freebsd-x86_64) + * [FreeBSD 64-bit](https://get.haskellstack.org/stable/freebsd-x86_64.tar.gz) * Extract the archive and place `stack` somewhere on your `$PATH` (see [Path section below](#path)) diff --git a/doc/travis_ci.md b/doc/travis_ci.md --- a/doc/travis_ci.md +++ b/doc/travis_ci.md @@ -71,7 +71,7 @@ # Download and unpack the stack executable - mkdir -p ~/.local/bin - export PATH=$HOME/.local/bin:$PATH -- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' +- travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' ``` ## Installing GHC diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -164,11 +164,6 @@ number is likely simpler to use. In practice, both should guarantee equally reproducible build plans. -If unspecified, `subdirs` defaults to `['.']` (i.e. look only in the top-level -directory). Note that if you specify a value of `subdirs`, then `'.'` is _not_ -included by default and needs to be explicitly specified if a required package -is found in the top-level directory of the repository. - #### Local file path Like `packages`, local file paths can be used in `extra-deps`, and @@ -231,8 +226,11 @@ - wai ``` -If unspecified, `subdirs` defaults to `subdirs: [.]`, or looking for a -package in the root of the repo. +If unspecified, `subdirs` defaults to `['.']` meaning looking for a +package in the root of the repo.. Note that if you specify a value of +`subdirs`, then `'.'` is _not_ included by default and needs to be +explicitly specified if a required package is found in the top-level +directory of the repository. #### Archives (HTTP(S) or local filepath) @@ -747,6 +745,7 @@ copy-bins: false prefetch: false keep-going: false + keep-tmp-files: false # NOTE: global usage of haddock can cause build failures when documentation is # incorrectly formatted. This could also affect scripts which use stack. @@ -803,9 +802,10 @@ Templates used with `stack new` have a number of parameters that affect the generated code. These can be set for all new projects you create. The result of -them can be observed in the generated LICENSE and cabal files. +them can be observed in the generated LICENSE and cabal files. The value for all +of these parameters must be strings. -The 5 parameters are: `author-email`, `author-name`, `category`, `copyright` and `github-username`. +The parameters are: `author-email`, `author-name`, `category`, `copyright`, `year` and `github-username`. * _author-email_ - sets the `maintainer` property in cabal * _author-name_ - sets the `author` property in cabal and the name used in @@ -819,6 +819,9 @@ * _copyright_ - sets the `copyright` property in cabal. It is typically the name of the holder of the copyright on the package and the year(s) from which copyright is claimed. For example: `Copyright (c) 2006-2007 Joe Bloggs` +* _year_ - if `copyright` is not specified, `year` and `author-name` are used + to generate the copyright property in cabal. If `year` is not specified, it + defaults to the current year. * _github-username_ - used to generate `homepage` and `source-repository` in cabal. For instance `github-username: myusername` and `stack new my-project new-template` would result: @@ -838,7 +841,7 @@ author-name: Your Name author-email: youremail@example.com category: Your Projects Category - copyright: 'Copyright (c) 2017 Your Name' + copyright: 'Copyright (c) 2018 Your Name' github-username: yourusername ``` diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,340 +0,0 @@ -name: stack -version: '1.6.5' -synopsis: The Haskell Tool Stack -description: ! 'Please see the README.md for usage information, and - the wiki on Github for more details. Also, note that - the API for the library is not currently stable, and may - change significantly, even between minor releases. It is - currently only intended for use by the executable.' -category: Development -author: Commercial Haskell SIG -maintainer: manny@fpcomplete.com -license: BSD3 -github: commercialhaskell/stack -homepage: http://haskellstack.org -custom-setup: - dependencies: - - base - - Cabal - - filepath -extra-source-files: -- CONTRIBUTING.md -- ChangeLog.md -- README.md -- doc/*.md -- package.yaml -- src/setup-shim/StackSetupShim.hs -- stack.yaml -- test/package-dump/ghc-7.10.txt -- test/package-dump/ghc-7.8.4-osx.txt -- test/package-dump/ghc-7.8.txt -ghc-options: -- -Wall -- -fwarn-tabs -- -fwarn-incomplete-uni-patterns -- -fwarn-incomplete-record-updates -dependencies: -- Cabal -- aeson -- annotated-wl-pprint -- ansi-terminal -- async -- attoparsec -- base >=4.9 && < 5 -- base64-bytestring -- blaze-builder -- bytestring -- clock -- conduit -- conduit-extra -- containers -- cryptonite -- cryptonite-conduit -- deepseq -- directory -- echo -- exceptions -- extra -- fast-logger -- file-embed -- filelock -- filepath -- fsnotify -- generic-deriving -- hackage-security -- hashable -- hastache -- hpack -- hpc -- http-client -- http-client-tls -- http-conduit -- http-types -- memory -- microlens -- microlens-mtl -- mintty -- monad-logger -- mono-traversable -- mtl -- neat-interpolation -- network-uri -- open-browser -- optparse-applicative -- path -- path-io -- persistent -- persistent-sqlite -- persistent-template -- pretty -- primitive -- process -- project-template -- regex-applicative-text -- resourcet -- retry -- semigroups -- split -- stm -- store -- store-core -- streaming-commons -- tar -- template-haskell -- temporary -- text -- text-metrics -- th-reify-many -- time -- tls -- transformers -- unicode-transforms -- unix-compat -- unliftio -- unordered-containers -- vector -- yaml -- zip-archive -- zlib -when: -- condition: os(windows) - then: - cpp-options: -DWINDOWS - dependencies: - - Win32 - else: - build-tools: - - hsc2hs - dependencies: - - bindings-uname - - pid1 - - unix -library: - source-dirs: src/ - ghc-options: - - -fwarn-identities - exposed-modules: - - Control.Concurrent.Execute - - Data.Aeson.Extended - - Data.Attoparsec.Args - - Data.Attoparsec.Combinators - - Data.Attoparsec.Interpreter - - Data.IORef.RunOnce - - Data.Store.VersionTagged - - Network.HTTP.Download - - Network.HTTP.Download.Verified - - Options.Applicative.Args - - Options.Applicative.Builder.Extra - - Options.Applicative.Complicated - - Path.CheckInstall - - Path.Extra - - Path.Find - - Paths_stack - - Stack.Build - - Stack.Build.Cache - - Stack.Build.ConstructPlan - - Stack.Build.Execute - - Stack.Build.Haddock - - Stack.Build.Installed - - Stack.Build.Source - - Stack.Build.Target - - Stack.BuildPlan - - Stack.Clean - - Stack.Config - - Stack.Config.Build - - Stack.Config.Urls - - Stack.Config.Docker - - Stack.Config.Nix - - Stack.ConfigCmd - - Stack.Constants - - Stack.Constants.Config - - Stack.Coverage - - Stack.Docker - - Stack.Docker.GlobalDB - - Stack.Dot - - Stack.Exec - - Stack.Fetch - - Stack.FileWatch - - Stack.GhcPkg - - Stack.Ghci - - Stack.Ghci.Script - - Stack.Hoogle - - Stack.IDE - - Stack.Image - - Stack.Init - - Stack.New - - Stack.Nix - - Stack.Options.BenchParser - - Stack.Options.BuildMonoidParser - - Stack.Options.BuildParser - - Stack.Options.CleanParser - - Stack.Options.ConfigParser - - Stack.Options.Completion - - Stack.Options.DockerParser - - Stack.Options.DotParser - - Stack.Options.ExecParser - - Stack.Options.GhcBuildParser - - Stack.Options.GhciParser - - Stack.Options.GhcVariantParser - - Stack.Options.GlobalParser - - Stack.Options.HaddockParser - - Stack.Options.HpcReportParser - - Stack.Options.LogLevelParser - - Stack.Options.NewParser - - Stack.Options.NixParser - - 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.Prelude - - Stack.PrettyPrint - - Stack.Runners - - Stack.Script - - Stack.SDist - - Stack.Setup - - Stack.Setup.Installed - - Stack.SetupCmd - - Stack.Sig - - Stack.Sig.GPG - - Stack.Sig.Sign - - Stack.Snapshot - - Stack.Solver - - Stack.StaticBytes - - Stack.Types.Build - - Stack.Types.BuildPlan - - Stack.Types.CompilerBuild - - Stack.Types.Urls - - Stack.Types.Compiler - - Stack.Types.Config - - Stack.Types.Config.Build - - Stack.Types.Docker - - Stack.Types.FlagName - - Stack.Types.GhcPkgId - - Stack.Types.Image - - Stack.Types.Nix - - Stack.Types.Package - - Stack.Types.PackageDump - - Stack.Types.PackageIdentifier - - Stack.Types.PackageIndex - - Stack.Types.PackageName - - Stack.Types.Resolver - - Stack.Types.Runner - - Stack.Types.Sig - - Stack.Types.TemplateName - - Stack.Types.Version - - Stack.Types.VersionIntervals - - Stack.Upgrade - - Stack.Upload - - Text.PrettyPrint.Leijen.Extended - - System.Process.Log - - System.Process.PagerEditor - - System.Process.Read - - System.Process.Run - - System.Terminal - other-modules: - - Hackage.Security.Client.Repository.HttpLib.HttpClient - when: - - condition: 'os(windows)' - then: - source-dirs: src/windows/ - else: - source-dirs: src/unix/ -executables: - stack: - main: Main.hs - source-dirs: src/main - ghc-options: - - -threaded - dependencies: - - stack - other-modules: - - Paths_stack - when: - - condition: flag(static) - ld-options: - - -static - - -pthread - - condition: ! '!(flag(disable-git-info))' - cpp-options: -DUSE_GIT_INFO - dependencies: - - gitrev - - optparse-simple - - condition: flag(hide-dependency-versions) - cpp-options: -DHIDE_DEP_VERSIONS - - condition: flag(supported-build) - cpp-options: -DSUPPORTED_BUILD -tests: - stack-test: - main: Test.hs - source-dirs: src/test - ghc-options: - - -threaded - dependencies: - - QuickCheck - - hspec - - stack - - smallcheck - stack-integration-test: - main: IntegrationSpec.hs - source-dirs: - - test/integration - - test/integration/lib - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - hspec - when: - - condition: ! '!(flag(integration-tests))' - buildable: false -flags: - static: - description: Pass -static/-pthread to ghc when linking the stack binary. - manual: true - default: false - disable-git-info: - description: Disable compile-time inclusion of current git info in stack - manual: true - default: false - hide-dependency-versions: - description: Hides dependency versions from "stack --version", used only by building - with stack.yaml - manual: true - default: false - integration-tests: - description: Run the integration test suite - manual: true - default: false - supported-build: - description: If false, causes "stack --version" to issue a warning about the build being unsupported. True only if building with stack.yaml - manual: true - default: false diff --git a/src/Control/Concurrent/Execute.hs b/src/Control/Concurrent/Execute.hs --- a/src/Control/Concurrent/Execute.hs +++ b/src/Control/Concurrent/Execute.hs @@ -8,32 +8,49 @@ , ActionId (..) , ActionContext (..) , Action (..) + , Concurrency(..) , runActions ) where import Control.Concurrent.STM (retry) import Stack.Prelude +import Data.List (sortBy) import qualified Data.Set as Set import Stack.Types.PackageIdentifier data ActionType = ATBuild + -- ^ Action for building a package's library and executables. If + -- 'taskAllInOne' is 'True', then this will also build benchmarks + -- and tests. It is 'False' when then library's benchmarks or + -- test-suites have cyclic dependencies. | ATBuildFinal - | ATFinal + -- ^ Task for building the package's benchmarks and test-suites. + -- Requires that the library was already built. + | ATRunTests + -- ^ Task for running the package's test-suites. + | ATRunBenchmarks + -- ^ Task for running the package's benchmarks. deriving (Show, Eq, Ord) data ActionId = ActionId !PackageIdentifier !ActionType deriving (Show, Eq, Ord) data Action = Action - { actionId :: !ActionId + { actionId :: !ActionId , actionDeps :: !(Set ActionId) - , actionDo :: !(ActionContext -> IO ()) + , actionDo :: !(ActionContext -> IO ()) + , actionConcurrency :: !Concurrency } +data Concurrency = ConcurrencyAllowed | ConcurrencyDisallowed + deriving (Eq) + data ActionContext = ActionContext { acRemaining :: !(Set ActionId) -- ^ Does not include the current action , acDownstream :: [Action] -- ^ Actions which depend on the current action + , acConcurrency :: !Concurrency + -- ^ Whether this action may be run concurrently with others } data ExecuteState = ExecuteState @@ -41,7 +58,6 @@ , esExceptions :: TVar [SomeException] , esInAction :: TVar (Set ActionId) , esCompleted :: TVar Int - , esFinalLock :: Maybe (TMVar ()) , esKeepGoing :: Bool } @@ -56,26 +72,34 @@ runActions :: Int -- ^ threads -> Bool -- ^ keep going after one task has failed - -> Bool -- ^ run final actions concurrently? -> [Action] - -> (TVar Int -> IO ()) -- ^ progress updated + -> (TVar Int -> TVar (Set ActionId) -> IO ()) -- ^ progress updated -> IO [SomeException] -runActions threads keepGoing concurrentFinal actions0 withProgress = do +runActions threads keepGoing actions0 withProgress = do es <- ExecuteState - <$> newTVarIO actions0 + <$> newTVarIO (sortActions actions0) <*> newTVarIO [] <*> newTVarIO Set.empty <*> newTVarIO 0 - <*> (if concurrentFinal - then pure Nothing - else Just <$> atomically (newTMVar ())) <*> pure keepGoing - _ <- async $ withProgress $ esCompleted es + _ <- async $ withProgress (esCompleted es) (esInAction es) if threads <= 1 then runActions' es else replicateConcurrently_ threads $ runActions' es readTVarIO $ esExceptions es +-- | Sort actions such that those that can't be run concurrently are at +-- the end. +sortActions :: [Action] -> [Action] +sortActions = sortBy (compareConcurrency `on` actionConcurrency) + where + -- NOTE: Could derive Ord. However, I like to make this explicit so + -- that changes to the datatype must consider how it's affecting + -- this. + compareConcurrency ConcurrencyAllowed ConcurrencyDisallowed = LT + compareConcurrency ConcurrencyDisallowed ConcurrencyAllowed = GT + compareConcurrency _ _ = EQ + runActions' :: ExecuteState -> IO () runActions' ExecuteState {..} = loop @@ -101,16 +125,12 @@ return $ return () else retry (xs, action:ys) -> do - unlock <- - case (actionId action, esFinalLock) of - (ActionId _ ATFinal, Just lock) -> do - takeTMVar lock - return $ putTMVar lock () - _ -> return $ return () - - let as' = xs ++ ys inAction <- readTVar esInAction - let remaining = Set.union + case actionConcurrency action of + ConcurrencyAllowed -> return () + ConcurrencyDisallowed -> unless (Set.null inAction) retry + let as' = xs ++ ys + remaining = Set.union (Set.fromList $ map actionId as') inAction writeTVar esActions as' @@ -119,9 +139,9 @@ eres <- try $ restore $ actionDo action ActionContext { acRemaining = remaining , acDownstream = downstreamActions (actionId action) as' + , acConcurrency = actionConcurrency action } atomically $ do - unlock modifyTVar esInAction (Set.delete $ actionId action) modifyTVar esCompleted (+1) case eres of diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -100,10 +100,10 @@ -- | Log JSON warnings. logJSONWarnings - :: MonadLogger m + :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) => FilePath -> [JSONWarning] -> m () logJSONWarnings fp = - mapM_ (\w -> logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w))) + mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) -- | Handle warnings in a sub-object. jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a @@ -142,24 +142,29 @@ { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning] } deriving Generic +instance Semigroup WarningParserMonoid where + (<>) = mappenddefault instance Monoid WarningParserMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) instance IsString WarningParserMonoid where fromString s = mempty { wpmWarnings = [fromString s] } -- Parsed JSON value with its warnings data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] - deriving Generic + deriving (Eq, Generic, Show) instance Functor WithJSONWarnings where fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w +instance Monoid a => Semigroup (WithJSONWarnings a) where + (<>) = mappenddefault instance Monoid a => Monoid (WithJSONWarnings a) where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Warning output from 'WarningParser'. data JSONWarning = JSONUnrecognizedFields String [Text] | JSONGeneralWarning !Text + deriving Eq instance Show JSONWarning where show (JSONUnrecognizedFields obj [field]) = "Unrecognized field in " <> obj <> ": " <> T.unpack field diff --git a/src/Data/Attoparsec/Combinators.hs b/src/Data/Attoparsec/Combinators.hs --- a/src/Data/Attoparsec/Combinators.hs +++ b/src/Data/Attoparsec/Combinators.hs @@ -6,7 +6,7 @@ import Stack.Prelude -- | Concatenate two parsers. -appending :: (Applicative f,Monoid a) +appending :: (Applicative f,Semigroup a) => f a -> f a -> f a appending a b = (<>) <$> a <*> b diff --git a/src/Data/Attoparsec/Interpreter.hs b/src/Data/Attoparsec/Interpreter.hs --- a/src/Data/Attoparsec/Interpreter.hs +++ b/src/Data/Attoparsec/Interpreter.hs @@ -60,7 +60,6 @@ import Data.Char (isSpace) import Data.Conduit import Data.Conduit.Attoparsec -import qualified Data.Conduit.Binary as CB import Data.Conduit.Text (decodeUtf8) import Data.List (intercalate) import Data.Text (pack) @@ -113,15 +112,16 @@ -- comment when it is being used as an interpreter getInterpreterArgs :: String -> IO [String] getInterpreterArgs file = do - eArgStr <- withBinaryFile file ReadMode parseFile + eArgStr <- withSourceFile file parseFile case eArgStr of Left err -> handleFailure $ decodeError err Right str -> parseArgStr str where - parseFile h = - CB.sourceHandle h - =$= decodeUtf8 - $$ sinkParserEither (interpreterArgsParser isLiterate stackProgName) + parseFile src = + runConduit + $ src + .| decodeUtf8 + .| sinkParserEither (interpreterArgsParser isLiterate stackProgName) isLiterate = takeExtension file == ".lhs" diff --git a/src/Data/Store/VersionTagged.hs b/src/Data/Store/VersionTagged.hs --- a/src/Data/Store/VersionTagged.hs +++ b/src/Data/Store/VersionTagged.hs @@ -22,7 +22,6 @@ import Data.Store import Data.Store.Core (unsafeEncodeWith) import Data.Store.Version -import qualified Data.Text as T import Language.Haskell.TH import Path import Path.IO (ensureDir) @@ -37,14 +36,14 @@ versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |] -- | Write to the given file. -storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a) +storeEncodeFile :: (Store a, MonadIO m, MonadReader env m, HasCallStack, HasLogFunc env, Eq a) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File -> a -> m () storeEncodeFile pokeFunc peekFunc fp x = do - let fpt = T.pack (toFilePath fp) + let fpt = fromString (toFilePath fp) logDebug $ "Encoding " <> fpt ensureDir (parent fp) let (sz, poker) = pokeFunc x @@ -55,14 +54,14 @@ -- | 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, MonadUnliftIO m, MonadLogger m) +versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env) => (a -> (Int, Poke ())) -> Peek a -> Path Abs File -> m a -> m a versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do - let fpt = T.pack (toFilePath fp) + let fpt = fromString (toFilePath fp) logDebug $ "Trying to decode " <> fpt mres <- versionedDecodeFileImpl peekFunc fp case mres of @@ -75,20 +74,20 @@ storeEncodeFile pokeFunc peekFunc fp x return x -versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m) +versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env) => Peek a -> Path loc File -> m (Maybe a) versionedDecodeFileImpl peekFunc fp = do mbs <- liftIO (Just <$> BS.readFile (toFilePath fp)) `catch` \(err :: IOException) -> do - logDebug ("Exception ignored when attempting to load " <> T.pack (toFilePath fp) <> ": " <> T.pack (show err)) + logDebug ("Exception ignored when attempting to load " <> fromString (toFilePath fp) <> ": " <> displayShow err) return Nothing case mbs of Nothing -> return Nothing Just bs -> liftIO (Just <$> decodeIOWith peekFunc bs) `catch` \(err :: PeekException) -> do - let fpt = T.pack (toFilePath fp) - logDebug ("Error while decoding " <> fpt <> ": " <> T.pack (show err) <> " (this might not be an error, when switching between stack versions)") + let fpt = fromString (toFilePath fp) + logDebug ("Error while decoding " <> fpt <> ": " <> displayShow err <> " (this might not be an error, when switching between stack versions)") return Nothing storeVersionConfig :: String -> String -> VersionConfig a diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs --- a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -22,6 +22,7 @@ import qualified Data.ByteString.Char8 as BS.C8 import qualified Network.HTTP.Client as HttpClient import qualified Network.HTTP.Client.Internal as HttpClient +import qualified Network.HTTP.StackClient as StackClient import qualified Network.HTTP.Types as HttpClient import Hackage.Security.Client hiding (Header) @@ -69,7 +70,7 @@ -- the URI contains URL auth. Not sure if this is a concern. request' <- HttpClient.setUri HttpClient.defaultRequest uri let request = setRequestHeaders reqHeaders request' - checkHttpException $ HttpClient.withResponse request manager $ \response -> do + checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do let br = wrapCustomEx $ HttpClient.responseBody response callback (getResponseHeaders response) br @@ -82,7 +83,7 @@ request' <- HttpClient.setUri HttpClient.defaultRequest uri let request = setRange from to $ setRequestHeaders reqHeaders request' - checkHttpException $ HttpClient.withResponse request manager $ \response -> do + checkHttpException $ StackClient.withResponseByManager request manager $ \response -> do let br = wrapCustomEx $ HttpClient.responseBody response case () of () | HttpClient.responseStatus response == HttpClient.partialContent206 -> diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs --- a/src/Network/HTTP/Download.hs +++ b/src/Network/HTTP/Download.hs @@ -15,23 +15,26 @@ , download , redownload , httpJSON + , httpLbs + , httpLBS , parseRequest , parseUrlThrow , setGithubHeaders + , withResponse ) where import Stack.Prelude import Stack.Types.Runner import qualified Data.ByteString.Lazy as L import Data.Conduit (yield) -import Data.Conduit.Binary (sourceHandle) import qualified Data.Conduit.Binary as CB import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding (decodeUtf8With) import Network.HTTP.Client (Request, Response, path, checkResponse, parseUrlThrow, parseRequest) import Network.HTTP.Client.Conduit (requestHeaders) import Network.HTTP.Download.Verified -import Network.HTTP.Simple (httpJSON, withResponse, getResponseBody, getResponseHeaders, getResponseStatusCode, +import Network.HTTP.StackClient (httpJSON, httpLbs, httpLBS, withResponse) +import Network.HTTP.Simple (getResponseBody, getResponseHeaders, getResponseStatusCode, setRequestHeader) import Path.IO (doesFileExist) import System.Directory (createDirectoryIfMissing, @@ -44,10 +47,10 @@ -- appropriate destination. -- -- Throws an exception if things go wrong -download :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +download :: HasRunner env => Request -> Path Abs File -- ^ destination - -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? + -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)? download req destpath = do let downloadReq = DownloadRequest { drRequest = req @@ -61,12 +64,12 @@ -- | Same as 'download', but will download a file a second time if it is already present. -- -- Returns 'True' if the file was downloaded, 'False' otherwise -redownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +redownload :: HasRunner env => Request -> Path Abs File -- ^ destination - -> m Bool + -> RIO env Bool redownload req0 dest = do - logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0) + logDebug $ "Downloading " <> display (decodeUtf8With lenientDecode (path req0)) let destFilePath = toFilePath dest etagFilePath = destFilePath <.> "etag" @@ -75,8 +78,7 @@ if not exists then return Nothing else liftIO $ handleIO (const $ return Nothing) $ fmap Just $ - withBinaryFile etagFilePath ReadMode $ \h -> - runConduit $ sourceHandle h .| CB.take 512 + withSourceFile etagFilePath $ \src -> runConduit $ src .| CB.take 512 let req1 = case metag of @@ -97,10 +99,12 @@ -- force the download to happen again. handleIO (const $ return ()) $ removeFile etagFilePath - runConduitRes $ getResponseBody res .| CB.sinkFileCautious destFilePath + withSinkFileCautious destFilePath $ \sink -> + runConduit $ getResponseBody res .| sink forM_ (lookup "ETag" (getResponseHeaders res)) $ \e -> - runConduitRes $ yield e .| CB.sinkFileCautious etagFilePath + withSinkFileCautious etagFilePath $ \sink -> + runConduit $ yield e .| sink return True 304 -> return False @@ -112,5 +116,4 @@ -- | Set the user-agent request header setGithubHeaders :: Request -> Request -setGithubHeaders = setRequestHeader "User-Agent" ["The Haskell Stack"] - . setRequestHeader "Accept" ["application/vnd.github.v3+json"] +setGithubHeaders = setRequestHeader "Accept" ["application/vnd.github.v3+json"] diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -37,12 +37,13 @@ import Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16)) import Data.ByteString.Char8 (readInteger) import Data.Conduit -import Data.Conduit.Binary (sourceHandle, sinkHandle) +import Data.Conduit.Binary (sourceHandle) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import GHC.IO.Exception (IOException(..),IOErrorType(..)) import Network.HTTP.Client (getUri, path) -import Network.HTTP.Simple (Request, HttpException, httpSink, getResponseHeaders) +import Network.HTTP.StackClient (httpSink) +import Network.HTTP.Simple (Request, HttpException, getResponseHeaders) import Network.HTTP.Types.Header (hContentLength, hContentMD5) import Path import Stack.Types.Runner @@ -142,7 +143,7 @@ sinkCheckHash :: MonadThrow m => Request -> HashCheck - -> Consumer ByteString m () + -> ConduitM ByteString o m () sinkCheckHash req HashCheck{..} = do digest <- sinkHashUsing hashCheckAlgorithm let actualDigestString = show digest @@ -172,7 +173,7 @@ throwM $ WrongStreamLength req expectedStreamLength actualStreamLength -- | A more explicitly type-guided sinkHash. -sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a) +sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a) sinkHashUsing _ = sinkHash -- | Turns a list of hash checks into a ZipSink that checks all of them. @@ -180,8 +181,7 @@ hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req) -- 'Control.Retry.recovering' customized for HTTP failures -recoveringHttp :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) - => RetryPolicy -> m a -> m a +recoveringHttp :: forall env a. HasRunner env => RetryPolicy -> RIO env a -> RIO env a recoveringHttp retryPolicy = #if MIN_VERSION_retry(0,7,0) helper $ \run -> recovering retryPolicy (handlers run) . const @@ -189,15 +189,15 @@ helper $ \run -> recovering retryPolicy (handlers run) #endif where - helper :: (MonadUnliftIO m, HasRunner env, MonadReader env m) => (UnliftIO m -> IO a -> IO a) -> m a -> m a + helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action) - handlers :: (MonadLogger m, HasRunner env, MonadReader env m) => UnliftIO m -> [RetryStatus -> Handler IO Bool] - handlers run = [Handler . alwaysRetryHttp (unliftIO run),const $ Handler retrySomeIO] + handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool] + handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO] - alwaysRetryHttp :: (MonadLogger m', Monad m, HasRunner env, MonadReader env m') => (m' () -> m ()) -> RetryStatus -> HttpException -> m Bool - alwaysRetryHttp run rs _ = do - run $ + alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool + alwaysRetryHttp u rs _ = do + unliftIO u $ prettyWarn $ vcat [ flow $ unwords [ "Retry number" @@ -234,19 +234,19 @@ -- Throws VerifiedDownloadException. -- Throws IOExceptions related to file system operations. -- Throws HttpException. -verifiedDownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m) +verifiedDownload + :: HasRunner env => DownloadRequest -> Path Abs File -- ^ destination - -> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress - -> m Bool -- ^ Whether a download was performed + -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress + -> RIO env Bool -- ^ Whether a download was performed verifiedDownload DownloadRequest{..} destpath progressSink = do let req = drRequest whenM' (liftIO getShouldDownload) $ do - logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req) + logDebug $ "Downloading " <> Stack.Prelude.display (decodeUtf8With lenientDecode (path req)) liftIO $ createDirectoryIfMissing True dir - recoveringHttp drRetryPolicy $ liftIO $ - withBinaryFile fptmp WriteMode $ \h -> - httpSink req (go h) + recoveringHttp drRetryPolicy $ + withSinkFile fptmp $ httpSink req . go liftIO $ renameFile fptmp fp where whenM' mp m = do @@ -274,7 +274,9 @@ checkExpectations = withBinaryFile fp ReadMode $ \h -> do for_ drLengthCheck $ checkFileSizeExpectations h - sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks) + runConduit + $ sourceHandle h + .| getZipSink (hashChecksToZipSink drRequest drHashChecks) -- doesn't move the handle checkFileSizeExpectations h expectedFileSize = do @@ -293,7 +295,7 @@ throwM $ WrongContentLength drRequest expectedContentLength lengthBS _ -> return () - go h res = do + go sink res = do let headers = getResponseHeaders res mcontentLength = do hLength <- List.lookup hContentLength headers @@ -310,9 +312,9 @@ Nothing -> [] ) ++ drHashChecks - maybe id (\len -> (CB.isolate len =$=)) drLengthCheck + maybe id (\len -> (CB.isolate len .|)) drLengthCheck $ getZipSink ( hashChecksToZipSink drRequest hashChecks *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck - *> ZipSink (sinkHandle h) + *> ZipSink sink *> ZipSink (progressSink mcontentLength)) diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/StackClient.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Wrapper functions of 'Network.HTTP.Simple' and 'Network.HTTP.Client' to +-- add the 'User-Agent' HTTP request header to each request. + +module Network.HTTP.StackClient + ( httpJSON + , httpLbs + , httpLBS + , httpNoBody + , httpSink + , setUserAgent + , withResponse + , withResponseByManager + ) where + +import Data.Aeson (FromJSON) +import qualified Data.ByteString as Strict +import Data.ByteString.Lazy (ByteString) +import Data.Conduit (ConduitM, transPipe) +import Data.Void (Void) +import qualified Network.HTTP.Client +import Network.HTTP.Client (BodyReader, Manager, Request, Response) +import Network.HTTP.Simple (setRequestHeader) +import qualified Network.HTTP.Simple +import UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO) + + +setUserAgent :: Request -> Request +setUserAgent = setRequestHeader "User-Agent" ["The Haskell Stack"] + + +httpJSON :: (MonadIO m, FromJSON a) => Request -> m (Response a) +httpJSON = Network.HTTP.Simple.httpJSON . setUserAgent + + +httpLbs :: MonadIO m => Request -> m (Response ByteString) +httpLbs = Network.HTTP.Simple.httpLbs . setUserAgent + + +httpLBS :: MonadIO m => Request -> m (Response ByteString) +httpLBS = httpLbs + + +httpNoBody :: MonadIO m => Request -> m (Response ()) +httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent + + +httpSink + :: MonadUnliftIO m + => Request + -> (Response () -> ConduitM Strict.ByteString Void m a) + -> m a +httpSink req inner = withUnliftIO $ \u -> + Network.HTTP.Simple.httpSink (setUserAgent req) (transPipe (unliftIO u) . inner) + + +withResponse + :: (MonadUnliftIO m, MonadIO n) + => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a +withResponse req inner = withRunInIO $ \run -> + Network.HTTP.Simple.withResponse (setUserAgent req) (run . inner) + + +withResponseByManager :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m a) -> m a +withResponseByManager req man inner = withRunInIO $ \run -> + Network.HTTP.Client.withResponse (setUserAgent req) man (run . inner) diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -32,7 +32,7 @@ import Data.List (isPrefixOf) import Data.Maybe -import Data.Monoid +import Data.Monoid hiding ((<>)) import qualified Data.Text as T import Options.Applicative import Options.Applicative.Types (readerAsk) diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs --- a/src/Path/Extra.hs +++ b/src/Path/Extra.hs @@ -22,7 +22,7 @@ import Path import Path.IO import Path.Internal (Path(..)) -import Stack.Prelude +import RIO import System.IO.Error (isDoesNotExistError) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -14,7 +14,7 @@ module Stack.Build (build - ,withLoadPackage + ,loadPackage ,mkBaseConfigOpts ,queryBuildInfo ,splitObjsWarning @@ -24,7 +24,7 @@ import Stack.Prelude import Data.Aeson (Value (Object, Array), (.=), object) import qualified Data.HashMap.Strict as HM -import Data.List ((\\)) +import Data.List ((\\), isPrefixOf) import Data.List.Extra (groupSort) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE @@ -42,21 +42,23 @@ import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target -import Stack.Fetch as Fetch import Stack.Package import Stack.PackageLocation (parseSingleCabalFileIndex) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version +import Stack.Types.Compiler (compilerVersionText #ifdef WINDOWS -import Stack.Types.Compiler + ,getGhcVersion #endif + ) import System.FileLock (FileLock, unlockFile) #ifdef WINDOWS @@ -77,9 +79,8 @@ bopts <- view buildOptsL let profiling = boptsLibProfile bopts || boptsExeProfile bopts let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts) - menv <- getMinimalEnvOverride - (targets, mbp, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli + (targets, ls, locals, extraToBuild, sourceMap) <- loadSourceMapFull NeedTargets boptsCli -- Set local files, necessary for file watching stackYaml <- view stackYamlL @@ -95,7 +96,7 @@ [lpFiles lp | PSFiles lp _ <- Map.elems sourceMap] (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <- - getInstalled menv + getInstalled GetInstalledOpts { getInstalledProfiling = profiling , getInstalledHaddock = shouldHaddockDeps bopts @@ -103,8 +104,7 @@ sourceMap baseConfigOpts <- mkBaseConfigOpts boptsCli - plan <- withLoadPackage $ \loadPackage -> - constructPlan mbp baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) + plan <- constructPlan ls baseConfigOpts locals extraToBuild localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) allowLocals <- view $ configL.to configAllowLocals unless allowLocals $ case justLocals plan of @@ -130,7 +130,7 @@ if boptsCLIDryrun boptsCli then printPlan plan - else executePlan menv boptsCli baseConfigOpts locals + else executePlan boptsCli baseConfigOpts locals globalDumpPkgs snapshotDumpPkgs localDumpPkgs @@ -172,7 +172,7 @@ -- | See https://github.com/commercialhaskell/stack/issues/1198. warnIfExecutablesWithSameNameCouldBeOverwritten - :: MonadLogger m => [LocalPackage] -> Plan -> m () + :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env () warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do logDebug "Checking if we are going to build multiple executables with the same name" forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do @@ -183,7 +183,7 @@ T.intercalate ", " ["'" <> packageNameText p <> ":" <> exe <> "'" | p <- pkgs] - (logWarn . T.unlines . concat) + (logWarn . display . T.unlines . concat) [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ] , [ "Only one of them will be available via 'stack exec' or locally installed." | length toBuild > 1 @@ -239,9 +239,9 @@ collect :: Ord k => [(k,v)] -> Map k (NonEmpty v) collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort -warnAboutSplitObjs :: MonadLogger m => BuildOpts -> m () +warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env () warnAboutSplitObjs bopts | boptsSplitObjs bopts = do - logWarn $ "Building with --split-objs is enabled. " <> T.pack splitObjsWarning + logWarn $ "Building with --split-objs is enabled. " <> fromString splitObjsWarning warnAboutSplitObjs _ = return () splitObjsWarning :: String @@ -273,29 +273,25 @@ } -- | Provide a function for loading package information from the package index -withLoadPackage :: HasEnvConfig env - => ((PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -> RIO env a) - -> RIO env a -withLoadPackage inner = do - econfig <- view envConfigL - root <- view projectRootL - run <- askRunInIO - withCabalLoader $ \loadFromIndex -> - inner $ \loc flags ghcOptions -> run $ - resolvePackage - (depPackageConfig econfig flags ghcOptions) - <$> parseSingleCabalFileIndex loadFromIndex root loc - where - -- | Package config to be used for dependencies - depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig - depPackageConfig econfig flags ghcOptions = PackageConfig +loadPackage + :: HasEnvConfig env + => PackageLocationIndex FilePath + -> Map FlagName Bool + -> [Text] + -> RIO env Package +loadPackage loc flags ghcOptions = do + compiler <- view actualCompilerVersionL + platform <- view platformL + root <- view projectRootL + let pkgConfig = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags , packageConfigGhcOptions = ghcOptions - , packageConfigCompilerVersion = view actualCompilerVersionL econfig - , packageConfigPlatform = view platformL econfig + , packageConfigCompilerVersion = compiler + , packageConfigPlatform = platform } + resolvePackage pkgConfig <$> parseSingleCabalFileIndex root loc -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 @@ -336,11 +332,10 @@ fixInput $ fixOutput inner expected = 65001 -- UTF-8 - warn typ = logInfo $ T.concat - [ "Setting" - , typ - , " codepage to UTF-8 (65001) to ensure correct output from GHC" - ] + warn typ = logInfo $ + "Setting" <> + typ <> + " codepage to UTF-8 (65001) to ensure correct output from GHC" #else fixCodePage = id #endif @@ -352,7 +347,7 @@ queryBuildInfo selectors0 = rawBuildInfo >>= select id selectors0 - >>= liftIO . TIO.putStrLn . decodeUtf8 . Yaml.encode + >>= liftIO . TIO.putStrLn . addGlobalHintsComment . decodeUtf8 . Yaml.encode where select _ [] value = return value select front (sel:sels) value = @@ -371,13 +366,35 @@ where cont = select (front . (sel:)) sels err msg = throwString $ msg ++ ": " ++ show (front [sel]) - + -- Include comments to indicate that this portion of the "stack + -- query" API is not necessarily stable. + addGlobalHintsComment + | null selectors0 = T.replace globalHintsLine ("\n" <> globalHintsComment <> globalHintsLine) + -- Append comment instead of pre-pending. The reasoning here is + -- that something *could* expect that the result of 'stack query + -- global-hints ghc-boot' is just a string literal. Seems easier + -- for to expect the first line of the output to be the literal. + | ["global-hints"] `isPrefixOf` selectors0 = (<> ("\n" <> globalHintsComment)) + | otherwise = id + globalHintsLine = "\nglobal-hints:\n" + globalHintsComment = T.concat + [ "# Note: global-hints is experimental and may be renamed / removed in the future.\n" + , "# See https://github.com/commercialhaskell/stack/issues/3796" + ] -- | Get the raw build information object rawBuildInfo :: HasEnvConfig env => RIO env Value rawBuildInfo = do (locals, _sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI + wantedCompiler <- view $ wantedCompilerVersionL.to compilerVersionText + actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText + globalHints <- view globalHintsL return $ object [ "locals" .= Object (HM.fromList $ map localToPair locals) + , "compiler" .= object + [ "wanted" .= wantedCompiler + , "actual" .= actualCompiler + ] + , "global-hints" .= globalHints ] where localToPair lp = diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -57,6 +57,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.Version @@ -119,29 +120,34 @@ let nonLibComponent prefix name = prefix <> "-" <> T.unpack name cacheFileName <- parseRelFile $ case component of CLib -> "lib" + CInternalLib name -> nonLibComponent "internal-lib" name CExe name -> nonLibComponent "exe" name CTest name -> nonLibComponent "test" name CBench name -> nonLibComponent "bench" name return $ cachesDir cacheFileName -- | Try to read the dirtiness cache for the given package directory. -tryGetBuildCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, MonadLogger m, HasEnvConfig env) - => Path Abs Dir -> NamedComponent -> m (Maybe (Map FilePath FileCacheInfo)) +tryGetBuildCache :: HasEnvConfig env + => Path Abs Dir + -> NamedComponent + -> RIO env (Maybe (Map FilePath FileCacheInfo)) tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component -- | Try to read the dirtiness cache for the given package directory. -tryGetConfigCache :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> m (Maybe ConfigCache) +tryGetConfigCache :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe ConfigCache) tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir -- | Try to read the mod time of the cabal file from the last build -tryGetCabalMod :: (MonadUnliftIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> m (Maybe ModTime) +tryGetCabalMod :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe ModTime) tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir -- | Write the dirtiness cache for this package's files. -writeBuildCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) - => Path Abs Dir -> NamedComponent -> Map FilePath FileCacheInfo -> m () +writeBuildCache :: HasEnvConfig env + => Path Abs Dir + -> NamedComponent + -> Map FilePath FileCacheInfo -> RIO env () writeBuildCache dir component times = do fp <- buildCacheFile dir component $(versionedEncodeFile buildCacheVC) fp BuildCache @@ -149,19 +155,19 @@ } -- | Write the dirtiness cache for this package's configuration. -writeConfigCache :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) +writeConfigCache :: HasEnvConfig env => Path Abs Dir -> ConfigCache - -> m () + -> RIO env () writeConfigCache dir x = do fp <- configCacheFile dir $(versionedEncodeFile configCacheVC) fp x -- | See 'tryGetCabalMod' -writeCabalMod :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env, MonadLogger m) +writeCabalMod :: HasEnvConfig env => Path Abs Dir -> ModTime - -> m () + -> RIO env () writeCabalMod dir x = do fp <- configCabalMod dir $(versionedEncodeFile modTimeVC) fp x @@ -189,42 +195,42 @@ return $ dir rel -- | Loads the flag cache for the given installed extra-deps -tryGetFlagCache :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +tryGetFlagCache :: HasEnvConfig env => Installed - -> m (Maybe ConfigCache) + -> RIO env (Maybe ConfigCache) tryGetFlagCache gid = do fp <- flagCacheFile gid $(versionedDecodeFile configCacheVC) fp -writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, MonadLogger m) +writeFlagCache :: HasEnvConfig env => Installed -> ConfigCache - -> m () + -> RIO env () writeFlagCache gid cache = do file <- flagCacheFile gid ensureDir (parent file) $(versionedEncodeFile configCacheVC) file cache -- | Mark a test suite as having succeeded -setTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +setTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m () + -> RIO env () setTestSuccess dir = do fp <- testSuccessFile dir $(versionedEncodeFile testSuccessVC) fp True -- | Mark a test suite as not having succeeded -unsetTestSuccess :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +unsetTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m () + -> RIO env () unsetTestSuccess dir = do fp <- testSuccessFile dir $(versionedEncodeFile testSuccessVC) fp False -- | Check if the test suite already passed -checkTestSuccess :: (MonadUnliftIO m, MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +checkTestSuccess :: HasEnvConfig env => Path Abs Dir - -> m Bool + -> RIO env Bool checkTestSuccess dir = liftM (fromMaybe False) @@ -247,11 +253,11 @@ -- -- We only pay attention to non-directory options. We don't want to avoid a -- cache hit just because it was installed in a different directory. -precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m) +precompiledCacheFile :: HasEnvConfig env => PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies - -> m (Maybe (Path Abs File)) + -> RIO env (Maybe (Path Abs File)) precompiledCacheFile loc copts installedPackageIDs = do ec <- view envConfigL @@ -312,14 +318,14 @@ return longPath -- | Write out information about a newly built package -writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m) +writePrecompiledCache :: HasEnvConfig env => BaseConfigOpts -> PackageLocationIndex FilePath -> ConfigureOpts -> Set GhcPkgId -- ^ dependencies -> Installed -- ^ library -> Set Text -- ^ executables - -> m () + -> RIO env () writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId exes = do mfile <- precompiledCacheFile loc copts depIDs forM_ mfile $ \file -> do diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -18,23 +18,22 @@ ( constructPlan ) where -import Stack.Prelude -import Control.Monad.RWS.Strict +import Stack.Prelude hiding (Display (..)) +import Control.Monad.RWS.Strict hiding ((<>)) import Control.Monad.State.Strict (execState) import qualified Data.HashSet as HashSet import Data.List -import Data.List.Extra (nubOrd) import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Distribution.Text as Cabal import qualified Distribution.Version as Cabal import Distribution.Types.BuildType (BuildType (Configure)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Lens.Micro (lens) +import qualified RIO import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -52,13 +51,14 @@ import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.IO (putStrLn) -import System.Process.Read (findExecutable) +import RIO.Process (findExecutable, HasProcessContext (..)) data PackageInfo = @@ -114,9 +114,11 @@ , wParents :: !ParentMap -- ^ Which packages a given package depends on, along with the package's version } deriving Generic +instance Semigroup W where + (<>) = mappenddefault instance Monoid W where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) type M = RWST -- TODO replace with more efficient WS stack on top of StackT Ctx @@ -127,7 +129,7 @@ data Ctx = Ctx { ls :: !LoadedSnapshot , baseConfigOpts :: !BaseConfigOpts - , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) + , loadPackage :: !(PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> M Package) , combinedMap :: !CombinedMap , toolToPackages :: !(ExeName -> Map PackageName VersionRange) , ctxEnvConfig :: !EnvConfig @@ -145,6 +147,10 @@ instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasCabalLoader Ctx where + cabalLoaderL = configL.cabalLoaderL +instance HasProcessContext Ctx where + processContextL = configL.processContextL instance HasBuildConfig Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -171,14 +177,13 @@ -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built -> [DumpPackage () () ()] -- ^ locally registered - -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package + -> (PackageLocationIndex FilePath -> Map FlagName Bool -> [Text] -> RIO EnvConfig Package) -- ^ load upstream package -> SourceMap -> InstalledMap -> Bool -> RIO env Plan constructPlan ls0 baseConfigOpts0 locals extraToBuild0 localDumpPkgs loadPackage0 sourceMap installedMap initialBuildSteps = do logDebug "Constructing the build plan" - u <- askUnliftIO econfig <- view envConfigL let onWanted = void . addDep False . packageName . lpPackage @@ -186,10 +191,10 @@ mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 lp <- getLocalPackages - let ctx = mkCtx econfig (unliftIO u . getPackageVersions) lp + let ctx = mkCtx econfig lp ((), m, W efinals installExes dirtyReason deps warnings parents) <- liftIO $ runRWST inner ctx M.empty - mapM_ logWarn (warnings []) + mapM_ (logWarn . RIO.display) (warnings []) let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m @@ -221,10 +226,10 @@ prettyErrorNoIndent $ pprintExceptions errs stackYaml parents (wanted ctx) throwM $ ConstructPlanFailed "Plan construction failed." where - mkCtx econfig getVersions0 lp = Ctx + mkCtx econfig lp = Ctx { ls = ls0 , baseConfigOpts = baseConfigOpts0 - , loadPackage = loadPackage0 + , loadPackage = \x y z -> runRIO econfig $ loadPackage0 x y z , combinedMap = combineMap sourceMap installedMap , toolToPackages = \name -> maybe Map.empty (Map.fromSet (const Cabal.anyVersion)) $ @@ -232,7 +237,7 @@ , ctxEnvConfig = econfig , callStack = [] , extraToBuild = extraToBuild0 - , getVersions = getVersions0 + , getVersions = runRIO econfig . getPackageVersions , wanted = wantedLocalPackages locals <> extraToBuild0 , localNames = Set.fromList $ map (packageName . lpPackage) locals } @@ -433,7 +438,7 @@ tellExecutablesUpstream pir@(PackageIdentifierRevision (PackageIdentifier name _) _) loc flags = do ctx <- ask when (name `Set.member` extraToBuild ctx) $ do - p <- liftIO $ loadPackage ctx (PLIndex pir) flags [] + p <- loadPackage ctx (PLIndex pir) flags [] tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M () @@ -470,7 +475,7 @@ case ps of PSIndex _ flags ghcOptions pkgLoc -> do planDebug $ "installPackage: Doing all-in-one build for upstream package " ++ show name - package <- liftIO $ loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! + package <- loadPackage ctx (PLIndex pkgLoc) flags ghcOptions -- FIXME be more efficient! Get this from the LoadedPackageInfo! resolveDepsAndInstall True treatAsDep ps package minstalled PSFiles lp _ -> case lpTestBench lp of @@ -578,7 +583,7 @@ -- | Is the build type of the package Configure packageBuildTypeConfig :: Package -> Bool -packageBuildTypeConfig pkg = packageBuildType pkg == Just Configure +packageBuildTypeConfig pkg = packageBuildType pkg == Configure -- Update response in the lib map. If it is an error, and there's -- already an error about cyclic dependencies, prefer the cyclic error. @@ -724,7 +729,7 @@ , configCacheDeps = Set.fromList $ Map.elems present , configCacheComponents = case ps of - PSFiles lp _ -> Set.map renderComponent $ lpComponents lp + PSFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp PSIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) || @@ -826,13 +831,11 @@ psLocal (PSFiles _ loc) = loc == Local -- FIXME this is probably not the right logic, see configureOptsNoDir. We probably want to check if this appears in packages: psLocal PSIndex{} = False --- | Get all of the dependencies for a given package, including guessed build +-- | Get all of the dependencies for a given package, including build -- tool dependencies. packageDepsWithTools :: Package -> M (Map PackageName (VersionRange, DepType)) packageDepsWithTools p = do ctx <- ask - -- TODO: it would be cool to defer these warnings until there's an - -- actual issue building the package. let toEither name mp = case Map.toList mp of [] -> Left (ToolWarning name (packageName p) Nothing) @@ -844,12 +847,13 @@ map (\dep -> toEither dep (toolToPackages ctx dep)) (Map.keys (packageTools p)) -- Check whether the tool is on the PATH before warning about it. warnings <- fmap catMaybes $ forM warnings0 $ \warning@(ToolWarning (ExeName toolName) _ _) -> do + let settings = minimalEnvSettings { esIncludeLocals = True } config <- view configL - menv <- liftIO $ configEnvOverride config minimalEnvSettings { esIncludeLocals = True } - mfound <- findExecutable menv $ T.unpack toolName + menv <- liftIO $ configProcessContextSettings config settings + mfound <- runRIO menv $ findExecutable $ T.unpack toolName case mfound of - Nothing -> return (Just warning) - Just _ -> return Nothing + Left _ -> return (Just warning) + Right _ -> return Nothing tell mempty { wWarnings = (map toolWarningText warnings ++) } return $ Map.unionsWith (\(vr1, dt1) (vr2, dt2) -> @@ -878,7 +882,7 @@ toolWarningText (ToolWarning (ExeName toolName) pkgName (Just (option1, option2, options))) = "Multiple packages found in snapshot which provide a " <> T.pack (show toolName) <> - " exeuctable, which is a build-tool dependency of " <> + " executable, which is a build-tool dependency of " <> T.pack (show (packageNameString pkgName)) <> ", so none will be installed.\n" <> "Here's the list of packages which provide it: " <> @@ -954,29 +958,33 @@ , line <> line , mconcat (intersperse (line <> line) (mapMaybe pprintException exceptions')) , line <> line - , flow "Some potential ways to resolve this:" + , flow "Some different approaches to resolving this:" , line <> line ] ++ + (if not onlyHasDependencyMismatches then [] else + [ " *" <+> align (flow "Set 'allow-newer: true' to ignore all version constraints and build anyway.") + , line <> line + ] + ) ++ + [ " *" <+> align (flow "Consider trying 'stack solver', which uses the cabal-install solver to attempt to find some working build configuration. This can be convenient when dealing with many complicated constraint errors, but results may be unpredictable.") + , line <> line + ] ++ (if Map.null extras then [] else [ " *" <+> align - (flow "Recommended action: try adding the following to your extra-deps in" <+> + (styleRecommendation (flow "Recommended action:") <+> + flow "try adding the following to your extra-deps in" <+> toAnsiDoc (display stackYaml) <> ":") , line <> line , vsep (map pprintExtra (Map.toList extras)) - , line <> line + , line ] - ) ++ - [ " *" <+> align (flow "Set 'allow-newer: true' to ignore all version constraints and build anyway.") - , line <> line - , " *" <+> align (flow "You may also want to try using the 'stack solver' command.") - , line - ] + ) where exceptions' = nubOrd exceptions extras = Map.unions $ map getExtras exceptions' - getExtras (DependencyCycleDetected _) = Map.empty - getExtras (UnknownPackage _) = Map.empty + getExtras DependencyCycleDetected{} = Map.empty + getExtras UnknownPackage{} = Map.empty getExtras (DependencyPlanFailures _ m) = Map.unions $ map go $ Map.toList m where @@ -994,6 +1002,17 @@ map fst $ filter (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) $ Map.toList pDeps toNotInBuildPlan _ = [] + -- This checks if 'allow-newer: true' could resolve all issues. + onlyHasDependencyMismatches = all go exceptions' + where + go DependencyCycleDetected{} = False + go UnknownPackage{} = False + go (DependencyPlanFailures _ m) = + all (\(_, _, depErr) -> isMismatch depErr) (M.elems m) + isMismatch DependencyMismatch{} = True + isMismatch Couldn'tResolveItsDependencies{} = True + isMismatch _ = False + pprintException (DependencyCycleDetected pNames) = Just $ flow "Dependency cycle detected in packages:" <> line <> indent 4 (encloseSep "[" "]" "," (map (styleError . display) pNames)) @@ -1032,13 +1051,15 @@ pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of NotInBuildPlan -> Just $ styleError (display name) <+> - align (flow "must match" <+> goodRange <> "," <> softline <> - flow "but the stack configuration has no specified version" <> + align ((if range == Cabal.anyVersion + then flow "needed" + else flow "must match" <+> goodRange) <> "," <> softline <> + flow "but the stack configuration has no specified version" <+> latestApplicable Nothing) -- TODO: For local packages, suggest editing constraints DependencyMismatch version -> Just $ (styleError . display) (PackageIdentifier name version) <+> - align (flow "from stack configuration does not match" <+> goodRange <> + align (flow "from stack configuration does not match" <+> goodRange <+> latestApplicable (Just version)) -- I think the main useful info is these explain why missing -- packages are needed. Instead lets give the user the shortest @@ -1051,7 +1072,10 @@ goodRange = styleGood (fromString (Cabal.display range)) latestApplicable mversion = case mlatestApplicable of - Nothing -> "" + Nothing + | isNothing mversion -> + flow "(no package with that name found, perhaps there is a typo in a package's build-depends or an omission from the stack.yaml packages list?)" + | otherwise -> "" Just la | mlatestApplicable == mversion -> softline <> flow "(latest matching version is specified)" @@ -1126,8 +1150,11 @@ newtype MonoidMap k a = MonoidMap (Map k a) deriving (Eq, Ord, Read, Show, Generic, Functor) -instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where - mappend (MonoidMap mp1) (MonoidMap mp2) = MonoidMap (M.unionWith mappend mp1 mp2) +instance (Ord k, Semigroup a) => Semigroup (MonoidMap k a) where + MonoidMap mp1 <> MonoidMap mp2 = MonoidMap (M.unionWith (<>) mp1 mp2) + +instance (Ord k, Monoid a, Semigroup a) => Monoid (MonoidMap k a) where + mappend = (<>) mempty = MonoidMap mempty -- Switch this to 'True' to enable some debugging putStrLn in this module diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -25,16 +25,21 @@ import Control.Concurrent.Execute import Control.Concurrent.STM (check) -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Crypto.Hash import Data.Attoparsec.Text hiding (try) import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S import qualified Data.ByteString.Base64.URL as B64URL import Data.Char (isSpace) -import Data.Conduit hiding (runConduitRes) +import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed + (ExitCodeException (..), waitExitCode, + useHandleOpen, setStdin, setStdout, setStderr, getStdin, + createPipe, runProcess_, getStdout, + getStderr, createSource) import qualified Data.Conduit.Text as CT import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.IORef.RunOnce (runOnce) @@ -42,7 +47,6 @@ import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Data.Streaming.Process hiding (callProcess, env) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time.Clock (getCurrentTime) @@ -52,11 +56,11 @@ import Distribution.System (OS (Windows), Platform (Platform)) 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, withSystemTempDir) +import qualified RIO import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed @@ -75,6 +79,7 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -82,17 +87,11 @@ import Stack.Types.Version import qualified System.Directory as D import System.Environment (getExecutablePath) -import System.Exit (ExitCode (ExitSuccess)) +import System.Exit (ExitCode (..)) import qualified System.FilePath as FP -import System.IO (hPutStr, openBinaryFile) +import System.IO (hPutStr, stderr, stdout) import System.PosixCompat.Files (createLink) -import System.Process.Log (showProcessArgDebug, withProcessTimeLog) -import System.Process.Read -import System.Process.Run - -#if !MIN_VERSION_process(1,2,1) -import System.Process.Internals (createProcess_) -#endif +import RIO.Process -- | Has an executable been built or not? data ExecutableBuildStatus @@ -105,9 +104,9 @@ preFetch plan | Set.null idents = logDebug "Nothing to fetch" | otherwise = do - logDebug $ T.pack $ - "Prefetching: " ++ - intercalate ", " (map packageIdentifierString $ Set.toList idents) + logDebug $ + "Prefetching: " <> + mconcat (intersperse ", " (RIO.display <$> Set.toList idents)) fetchPackages idents where idents = Set.unions $ map toIdent $ Map.elems $ planTasks plan @@ -124,16 +123,11 @@ [] -> logInfo "No packages would be unregistered." xs -> do logInfo "Would unregister locally:" - forM_ xs $ \(ident, reason) -> logInfo $ T.concat - [ T.pack $ packageIdentifierString ident - , if T.null reason - then "" - else T.concat - [ " (" - , reason - , ")" - ] - ] + forM_ xs $ \(ident, reason) -> logInfo $ + RIO.display ident <> + if T.null reason + then "" + else " (" <> RIO.display reason <> ")" logInfo "" @@ -163,37 +157,35 @@ [] -> logInfo "No executables to be installed." xs -> do logInfo "Would install executables:" - forM_ xs $ \(name, loc) -> logInfo $ T.concat - [ name - , " from " - , case loc of - Snap -> "snapshot" - Local -> "local" - , " database" - ] + forM_ xs $ \(name, loc) -> logInfo $ + RIO.display name <> + " from " <> + (case loc of + Snap -> "snapshot" + Local -> "local") <> + " database" -- | For a dry run -displayTask :: Task -> Text -displayTask task = T.pack $ concat - [ packageIdentifierString $ taskProvides task - , ": database=" - , case taskLocation task of +displayTask :: Task -> Utf8Builder +displayTask task = + RIO.display (taskProvides task) <> + ": database=" <> + (case taskLocation task of Snap -> "snapshot" - Local -> "local" - , ", source=" - , case taskType task of - TTFiles lp _ -> toFilePath $ lpDir lp - TTIndex{} -> "package index" - , if Set.null missing + Local -> "local") <> + ", source=" <> + (case taskType task of + TTFiles lp _ -> fromString $ toFilePath $ lpDir lp + TTIndex{} -> "package index") <> + (if Set.null missing then "" - else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing) - ] + else ", after: " <> + mconcat (intersperse "," (RIO.display <$> Set.toList missing))) where missing = tcoMissing $ taskConfigOpts task data ExecuteEnv = ExecuteEnv - { eeEnvOverride :: !EnvOverride - , eeConfigureLock :: !(MVar ()) + { eeConfigureLock :: !(MVar ()) , eeInstallLock :: !(MVar ()) , eeBuildOpts :: !BuildOpts , eeBuildOptsCLI :: !BuildOptsCLI @@ -280,7 +272,7 @@ jsExeNameS = baseNameS ++ ".jsexe" setupDir = - configStackRoot config + view stackRootL config $(mkRelDir "setup-exe-cache") platformDir @@ -296,7 +288,6 @@ tmpOutputPath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ outputNameS tmpJsExePath <- fmap (setupDir ) $ parseRelDir $ "tmp-" ++ jsExeNameS ensureDir setupDir - menv <- getMinimalEnvOverride let args = buildSetupArgs ++ [ "-package" , "Cabal-" ++ cabalVersionString @@ -306,18 +297,19 @@ , toFilePath tmpOutputPath ] ++ ["-build-runner" | wc == Ghcjs] - callProcess' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) - `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + withWorkingDir (toFilePath tmpdir) (proc (compilerExeName wc) args $ \pc0 -> do + let pc = setStdout (useHandleOpen stderr) pc0 + runProcess_ pc) + `catch` \ece -> do compilerPath <- getCompilerPath wc - throwM $ SetupHsBuildFailure ec Nothing compilerPath args Nothing [] + throwM $ SetupHsBuildFailure (eceExitCode ece) Nothing compilerPath args Nothing [] when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath renameFile tmpExePath exePath return $ Just exePath -- | Execute a function that takes an 'ExecuteEnv'. withExecuteEnv :: forall env a. HasEnvConfig env - => EnvOverride - -> BuildOpts + => BuildOpts -> BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] @@ -326,8 +318,8 @@ -> [DumpPackage () () ()] -- ^ local packages -> (ExecuteEnv -> RIO env a) -> RIO env a -withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = - withSystemTempDir stackProgName $ \tmpdir -> do +withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = + createTempDirFunction stackProgName $ \tmpdir -> do configLock <- liftIO $ newMVar () installLock <- liftIO $ newMVar () idMap <- liftIO $ newTVarIO Map.empty @@ -339,7 +331,7 @@ -- Create files for simple setup and setup shim, if necessary let setupSrcDir = - configStackRoot config + view stackRootL config $(mkRelDir "setup-exe-src") ensureDir setupSrcDir setupFileName <- parseRelFile ("setup-" ++ simpleSetupHash ++ ".hs") @@ -353,15 +345,14 @@ setupExe <- getSetupExe setupHs setupShimHs tmpdir cabalPkgVer <- view cabalVersionL - globalDB <- getGlobalDB menv =<< view (actualCompilerVersionL.whichCompilerL) + globalDB <- getGlobalDB =<< view (actualCompilerVersionL.whichCompilerL) snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages) localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages) logFilesTChan <- liftIO $ atomically newTChan let totalWanted = length $ filter lpWanted locals env <- ask inner ExecuteEnv - { eeEnvOverride = menv - , eeBuildOpts = bopts + { eeBuildOpts = bopts , eeBuildOptsCLI = boptsCli -- Uncertain as to why we cannot run configures in parallel. This appears -- to be a Cabal library bug. Original issue: @@ -391,6 +382,10 @@ where toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp)) + createTempDirFunction + | Just True <- boptsKeepTmpFiles bopts = withKeepSystemTempDir + | otherwise = withSystemTempDir + dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env () dumpLogs chan totalWanted = do allLogs <- fmap reverse $ liftIO $ atomically drainChan @@ -404,13 +399,12 @@ DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs DumpNoLogs | totalWanted > 1 -> - logInfo $ T.concat - [ "Build output has been captured to log files, use " - , "--dump-logs to see it on the console" - ] + logInfo $ + "Build output has been captured to log files, use " <> + "--dump-logs to see it on the console" | otherwise -> return () - logInfo $ T.pack $ "Log files have been written to: " - ++ toFilePath (parent (snd firstLog)) + logInfo $ "Log files have been written to: " <> + fromString (toFilePath (parent (snd firstLog))) -- We only strip the colors /after/ we've dumped logs, so that -- we get pretty colors in our dump output on the terminal. @@ -428,13 +422,14 @@ dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env () dumpLogIfWarning (pkgDir, filepath) = do - firstWarning <- runResourceT - $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) - $$ CT.decodeUtf8Lenient - =$ CT.lines - =$ CL.map stripCR - =$ CL.filter isWarning - =$ CL.take 1 + firstWarning <- withSourceFile (toFilePath filepath) $ \src -> + runConduit + $ src + .| CT.decodeUtf8Lenient + .| CT.lines + .| CL.map stripCR + .| CL.filter isWarning + .| CL.take 1 unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, filepath) isWarning :: Text -> Bool @@ -443,23 +438,30 @@ dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env () dumpLog msgSuffix (pkgDir, filepath) = do - logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"] + logInfo $ + "\n-- Dumping log file" <> + fromString msgSuffix <> + ": " <> + fromString (toFilePath filepath) <> + "\n" compilerVer <- view actualCompilerVersionL - runResourceT - $ transPipe liftResourceT (CB.sourceFile (toFilePath filepath)) - $$ CT.decodeUtf8Lenient - =$ mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer - =$ CL.mapM_ logInfo - logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n" + withSourceFile (toFilePath filepath) $ \src -> + runConduit + $ src + .| CT.decodeUtf8Lenient + .| mungeBuildOutput ExcludeTHLoading ConvertPathsToAbsolute pkgDir compilerVer + .| CL.mapM_ (logInfo . RIO.display) + logInfo $ "\n-- End of log file: " <> fromString (toFilePath filepath) <> "\n" stripColors :: Path Abs File -> IO () stripColors fp = do let colorfp = toFilePath fp ++ "-color" - runConduitRes $ CB.sourceFile (toFilePath fp) .| CB.sinkFile colorfp - runConduitRes - $ CB.sourceFile colorfp - .| noColors - .| CB.sinkFile (toFilePath fp) + withSourceFile (toFilePath fp) $ \src -> + withSinkFile colorfp $ \sink -> + runConduit $ src .| sink + withSourceFile colorfp $ \src -> + withSinkFile (toFilePath fp) $ \sink -> + runConduit $ src .| noColors .| sink where noColors = do @@ -475,8 +477,7 @@ -- | Perform the actual plan executePlan :: HasEnvConfig env - => EnvOverride - -> BuildOptsCLI + => BuildOptsCLI -> BaseConfigOpts -> [LocalPackage] -> [DumpPackage () () ()] -- ^ global packages @@ -486,24 +487,24 @@ -> Map PackageName Target -> Plan -> RIO env () -executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do +executePlan boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do logDebug "Executing the build plan" bopts <- view buildOptsL - withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) + withExecuteEnv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan) copyExecutables (planInstallExes plan) config <- view configL - menv' <- liftIO $ configEnvOverride config EnvSettings + menv' <- liftIO $ configProcessContextSettings config EnvSettings { esIncludeLocals = True , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False , esKeepGhcRts = False } - forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> - withProcessTimeLog cmd args $ - callProcess (Cmd Nothing cmd menv' args) + withProcessContext menv' $ + forM_ (boptsCLIExec boptsCli) $ \(cmd, args) -> + proc cmd args runProcess_ copyExecutables :: HasEnvConfig env @@ -538,21 +539,19 @@ >>= rejectMissingFile case mfp of Nothing -> do - logWarn $ T.concat - [ "Couldn't find executable " - , name - , " in directory " - , T.pack $ toFilePath bindir - ] + logWarn $ + "Couldn't find executable " <> + RIO.display name <> + " in directory " <> + fromString (toFilePath bindir) return Nothing Just file -> do let destFile = destDir' FP. T.unpack name ++ ext - logInfo $ T.concat - [ "Copying from " - , T.pack $ toFilePath file - , " to " - , T.pack destFile - ] + logInfo $ + "Copying from " <> + fromString (toFilePath file) <> + " to " <> + fromString destFile liftIO $ case platform of Platform _ Windows | FP.equalFilePath destFile currExe -> @@ -562,11 +561,11 @@ unless (null installed) $ do logInfo "" - logInfo $ T.concat - [ "Copied executables to " - , T.pack destDir' - , ":"] - forM_ installed $ \exe -> logInfo ("- " <> exe) + logInfo $ + "Copied executables to " <> + fromString destDir' <> + ":" + forM_ installed $ \exe -> logInfo ("- " <> RIO.display exe) unless compilerSpecific $ warnInstallSearchPathIssues destDir' installed @@ -597,50 +596,48 @@ ids -> do localDB <- packageDatabaseLocal forM_ ids $ \(id', (ident, reason)) -> do - logInfo $ T.concat - [ T.pack $ packageIdentifierString ident - , ": unregistering" - , if T.null reason + logInfo $ + RIO.display ident <> + ": unregistering" <> + if T.null reason then "" - else T.concat - [ " (" - , reason - , ")" - ] - ] - unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident + else " (" <> RIO.display reason <> ")" + unregisterGhcPkgId wc cv localDB id' ident liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap -> foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan) run <- askRunInIO - let actions = concatMap (toActions installedMap' run ee) $ Map.elems $ Map.mergeWithKey + -- If running tests concurrently with eachother, then create an MVar + -- which is empty while each test is being run. + concurrentTests <- view $ configL.to configConcurrentTests + mtestLock <- if concurrentTests then return Nothing else Just <$> liftIO (newMVar ()) + + let actions = concatMap (toActions installedMap' mtestLock run ee) $ Map.elems $ Map.mergeWithKey (\_ b f -> Just (Just b, Just f)) (fmap (\b -> (Just b, Nothing))) (fmap (\f -> (Nothing, Just f))) (planTasks plan) (planFinals plan) threads <- view $ configL.to configJobs - concurrentTests <- view $ configL.to configConcurrentTests let keepGoing = - fromMaybe (boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts) (boptsKeepGoing eeBuildOpts) - concurrentFinal = - -- TODO it probably makes more sense to use a lock for test suites - -- and just have the execution blocked. Turning off all concurrency - -- on finals based on the --test option doesn't fit in well. - if boptsTests eeBuildOpts - then concurrentTests - else True + fromMaybe (not (M.null (planFinals plan))) (boptsKeepGoing eeBuildOpts) terminal <- view terminalL - errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do + errs <- liftIO $ runActions threads keepGoing actions $ \doneVar actionsVar -> do let total = length actions loop prev | prev == total = - run $ logStickyDone ("Completed " <> T.pack (show total) <> " action(s).") + run $ logStickyDone ("Completed " <> RIO.display total <> " action(s).") | otherwise = do + inProgress <- readTVarIO actionsVar + let packageNames = map (\(ActionId pkgID _) -> packageIdentifierText pkgID) (toList inProgress) + nowBuilding [] = "" + nowBuilding names = mconcat $ ": " : intersperse ", " (map RIO.display names) when terminal $ run $ - logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total)) + logSticky $ + "Progress " <> RIO.display prev <> "/" <> RIO.display total <> + nowBuilding packageNames done <- atomically $ do done <- readTVar doneVar check $ done /= prev @@ -654,9 +651,9 @@ when (boptsHaddock eeBuildOpts) $ do snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs) localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs) - generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals - generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals - generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs + generateLocalHaddockIndex wc eeBaseConfigOpts localDumpPkgs eeLocals + generateDepsHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals + generateSnapHaddockIndex wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs when (boptsOpenHaddocks eeBuildOpts) $ do let planPkgs, localPkgs, installedPkgs, availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation) @@ -676,11 +673,12 @@ toActions :: HasEnvConfig env => InstalledMap + -> Maybe (MVar ()) -> (RIO env () -> IO ()) -> ExecuteEnv -> (Maybe Task, Maybe Task) -- build and final -> [Action] -toActions installedMap runInBase ee (mbuild, mfinal) = +toActions installedMap mtestLock runInBase ee (mbuild, mfinal) = abuild ++ afinal where abuild = @@ -691,41 +689,59 @@ { actionId = ActionId taskProvides ATBuild , actionDeps = Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False + , actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap False + , actionConcurrency = ConcurrencyAllowed } ] afinal = case mfinal of Nothing -> [] Just task@Task {..} -> - (if taskAllInOne then [] else - [Action + (if taskAllInOne then id else (:) + Action { actionId = ActionId taskProvides ATBuildFinal , actionDeps = addBuild (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True - }]) ++ - [ Action - { actionId = ActionId taskProvides ATFinal - , actionDeps = - if taskAllInOne - then addBuild mempty - else Set.singleton (ActionId taskProvides ATBuildFinal) - , actionDo = \ac -> runInBase $ do - let comps = taskComponents task - tests = testComponents comps - benches = benchComponents comps - unless (Set.null tests) $ do - singleTest runInBase topts (Set.toList tests) ac ee task installedMap - unless (Set.null benches) $ do - singleBench runInBase beopts (Set.toList benches) ac ee task installedMap - } - ] + , actionDo = \ac -> runInBase $ singleBuild ac ee task installedMap True + , actionConcurrency = ConcurrencyAllowed + }) $ + -- These are the "final" actions - running tests and benchmarks. + (if Set.null tests then id else (:) + Action + { actionId = ActionId taskProvides ATRunTests + , actionDeps = finalDeps + , actionDo = \ac -> withLock mtestLock $ runInBase $ do + singleTest topts (Set.toList tests) ac ee task installedMap + -- Always allow tests tasks to run concurrently with + -- other tasks, particularly build tasks. Note that + -- 'mtestLock' can optionally make it so that only + -- one test is run at a time. + , actionConcurrency = ConcurrencyAllowed + }) $ + (if Set.null benches then id else (:) + Action + { actionId = ActionId taskProvides ATRunBenchmarks + , actionDeps = finalDeps + , actionDo = \ac -> runInBase $ do + singleBench beopts (Set.toList benches) ac ee task installedMap + -- Never run benchmarks concurrently with any other task, see #3663 + , actionConcurrency = ConcurrencyDisallowed + }) + [] where + comps = taskComponents task + tests = testComponents comps + benches = benchComponents comps + finalDeps = + if taskAllInOne + then addBuild mempty + else Set.singleton (ActionId taskProvides ATBuildFinal) addBuild = case mbuild of Nothing -> id Just _ -> Set.insert $ ActionId taskProvides ATBuild + withLock Nothing f = f + withLock (Just lock) f = withMVar lock $ \() -> f bopts = eeBuildOpts ee topts = boptsTestOpts bopts beopts = boptsBenchmarkOpts bopts @@ -774,7 +790,7 @@ , configCacheDeps = allDeps , configCacheComponents = case taskType of - TTFiles lp _ -> Set.map renderComponent $ lpComponents lp + TTFiles lp _ -> Set.map (encodeUtf8 . renderComponent) $ lpComponents lp TTIndex{} -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) @@ -820,16 +836,15 @@ when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce - menv <- getMinimalEnvOverride let programNames = if eeCabalPkgVer < $(mkVersion "1.22") then ["ghc", "ghc-pkg"] else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"] exes <- forM programNames $ \name -> do - mpath <- findExecutable menv name + mpath <- findExecutable name return $ case mpath of - Nothing -> [] - Just x -> return $ concat ["--with-", name, "=", toFilePath x] + Left _ -> [] + Right x -> return $ concat ["--with-", name, "=", x] -- Configure cabal with arguments determined by -- Stack.Types.Build.configureOpts cabal KeepTHLoading $ "configure" : concat @@ -850,17 +865,15 @@ let fp = pkgDir $(mkRelFile "configure") exists <- doesFileExist fp unless exists $ do - logInfo $ "Trying to generate configure with autoreconf in " <> T.pack (toFilePath pkgDir) - menv <- getMinimalEnvOverride - readProcessNull (Just pkgDir) menv "autoreconf" ["-i"] `catchAny` \ex -> - logWarn $ "Unable to run autoreconf: " <> T.pack (show ex) + logInfo $ "Trying to generate configure with autoreconf in " <> fromString (toFilePath pkgDir) + withWorkingDir (toFilePath pkgDir) $ readProcessNull "autoreconf" ["-i"] `catchAny` \ex -> + logWarn $ "Unable to run autoreconf: " <> displayShow ex -announceTask :: MonadLogger m => Task -> Text -> m () -announceTask task x = logInfo $ T.concat - [ T.pack $ packageIdentifierString $ taskProvides task - , ": " - , x - ] +announceTask :: HasLogFunc env => Task -> Text -> RIO env () +announceTask task x = logInfo $ + RIO.display (taskProvides task) <> + ": " <> + RIO.display x -- | This sets up a context for executing build steps which need to run -- Cabal (via a compiled Setup.hs). In particular it does the following: @@ -874,8 +887,7 @@ -- -- * Provides the user a function with which run the Cabal process. withSingleContext :: forall env a. HasEnvConfig env - => (RIO env () -> IO ()) - -> ActionContext + => ActionContext -> ExecuteEnv -> Task -> Maybe (Map PackageIdentifier GhcPkgId) @@ -893,7 +905,7 @@ -> Maybe (Path Abs File, Handle) -- Log file -> RIO env a) -> RIO env a -withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = +withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile pkgDir package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal -> @@ -906,9 +918,19 @@ TTFiles lp _ -> lpWanted lp TTIndex{} -> False - console = wanted - && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) - && eeTotalWanted == 1 + -- Output to the console if this is the last task, and the user + -- asked to build it specifically. When the action is a + -- 'ConcurrencyDisallowed' action (benchmarks), then we can also be + -- sure to have excluse access to the console, so output is also + -- sent to the console in this case. + -- + -- See the discussion on #426 for thoughts on sending output to the + -- console from concurrent tasks. + console = + (wanted && + all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining) && + eeTotalWanted == 1 + ) || (acConcurrency == ConcurrencyDisallowed) withPackage inner = case taskType of @@ -935,10 +957,7 @@ liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath) _ -> return () - bracket - (liftIO $ openBinaryFile fp WriteMode) - (liftIO . hClose) - $ \h -> inner (Just (logPath, h)) + withBinaryFile fp WriteMode $ \h -> inner (Just (logPath, h)) withCabal :: Package @@ -959,14 +978,14 @@ , esLocaleUtf8 = True , esKeepGhcRts = False } - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configProcessContextSettings config envSettings distRelativeDir' <- distRelativeDir esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: -- https://github.com/commercialhaskell/stack/issues/370 case (packageBuildType package, eeSetupExe) of - (Just C.Simple, Just setupExe) -> return $ Left setupExe + (C.Simple, Just setupExe) -> return $ Left setupExe _ -> liftIO $ Right <$> getSetupHs pkgDir inner $ \stripTHLoading args -> do let cabalPackageArg @@ -991,7 +1010,7 @@ warnCustomNoDeps :: RIO env () warnCustomNoDeps = case (taskType, packageBuildType package) of - (TTFiles lp Local, Just C.Custom) | lpWanted lp -> do + (TTFiles lp Local, C.Custom) | lpWanted lp -> do prettyWarnL [ flow "Package" , display $ packageName package @@ -1026,10 +1045,10 @@ case filter (matches . fst) (Map.toList allDeps) of x:xs -> do unless (null xs) - (logWarn (T.pack ("Found multiple installed packages for custom-setup dep: " ++ packageNameString name))) + (logWarn ("Found multiple installed packages for custom-setup dep: " <> RIO.display name)) return ("-package-id=" ++ ghcPkgIdString (snd x), Just (toCabalPackageIdentifier (fst x))) [] -> do - logWarn (T.pack ("Could not find custom-setup dep: " ++ packageNameString name)) + logWarn ("Could not find custom-setup dep: " <> RIO.display name) return ("-package=" ++ packageNameString name, Nothing) let depsArgs = map fst matchedDeps -- Generate setup_macros.h and provide it to ghc @@ -1088,19 +1107,20 @@ runExe :: Path Abs File -> [String] -> RIO env () runExe exeName fullArgs = do compilerVer <- view actualCompilerVersionL - runAndOutput compilerVer `catch` \(ProcessExitedUnsuccessfully _ ec) -> do + runAndOutput compilerVer `catch` \ece -> do bss <- case mlogFile of Nothing -> return [] Just (logFile, h) -> do liftIO $ hClose h - runResourceT - $ transPipe liftResourceT (CB.sourceFile (toFilePath logFile)) - =$= CT.decodeUtf8Lenient - $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer - =$ CL.consume + withSourceFile (toFilePath logFile) $ \src -> + runConduit + $ src + .| CT.decodeUtf8Lenient + .| mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer + .| CL.consume throwM $ SetupHsBuildFailure - ec + (eceExitCode ece) (Just taskProvides) exeName fullArgs @@ -1108,22 +1128,27 @@ bss where runAndOutput :: CompilerVersion 'CVActual -> RIO env () - runAndOutput compilerVer = case mlogFile of + runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $ withProcessContext menv $ case mlogFile of Just (_, h) -> - sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h + proc (toFilePath exeName) fullArgs + $ runProcess_ + . setStdin (byteStringInput "") + . setStdout (useHandleOpen h) + . setStderr (useHandleOpen h) Nothing -> - void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs + void $ sinkProcessStderrStdout (toFilePath exeName) fullArgs (outputSink KeepTHLoading LevelWarn compilerVer) (outputSink stripTHLoading LevelInfo compilerVer) outputSink - :: ExcludeTHLoading + :: HasCallStack + => ExcludeTHLoading -> LogLevel -> CompilerVersion 'CVActual - -> Sink S.ByteString IO () + -> ConduitM S.ByteString Void (RIO env) () outputSink excludeTH level compilerVer = CT.decodeUtf8Lenient - =$ mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer - =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level) + .| mungeBuildOutput excludeTH makeAbsolute pkgDir compilerVer + .| CL.mapM_ (logGeneric "" level . RIO.display) -- If users want control, we should add a config option for this makeAbsolute :: ConvertPathsToAbsolute makeAbsolute = case stripTHLoading of @@ -1185,14 +1210,13 @@ -- with @copy@, and not the copying done by @stack install@ - that is -- handled by 'copyExecutables'. singleBuild :: forall env. (HasEnvConfig env, HasRunner env) - => (RIO env () -> IO ()) - -> ActionContext + => ActionContext -> ExecuteEnv -> Task -> InstalledMap -> Bool -- ^ Is this a final build? -> RIO env () -singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do +singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap isFinalBuild = do (allDepsMap, cache) <- getConfigCache ee task installedMap enableTests enableBenchmarks mprecompiled <- getPrecompiled cache minstalled <- @@ -1271,36 +1295,34 @@ wc <- view $ actualCompilerVersionL.whichCompilerL announceTask task "using precompiled package" forM_ mlib $ \libpath -> do - menv <- getMinimalEnvOverride withMVar eeInstallLock $ \() -> do -- We want to ignore the global and user databases. -- Unfortunately, ghc-pkg doesn't take such arguments on the -- command line. Instead, we'll set GHC_PACKAGE_PATH. See: -- https://github.com/commercialhaskell/stack/issues/1146 - menv' <- modifyEnvOverride menv - $ Map.insert - (ghcPkgPathEnvVar wc) - (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) + let modifyEnv = Map.insert + (ghcPkgPathEnvVar wc) + (T.pack $ toFilePathNoTrailingSep $ bcoSnapDB eeBaseConfigOpts) - -- In case a build of the library with different flags already exists, unregister it - -- before copying. - let ghcPkgExe = ghcPkgExeName wc - catch - (readProcessNull Nothing menv' ghcPkgExe - [ "unregister" - , "--force" - , packageIdentifierString taskProvides - ]) - (\ex -> case ex of - ProcessFailed{} -> return () - _ -> throwM ex) + withModifyEnvVars modifyEnv $ do + -- In case a build of the library with different flags already exists, unregister it + -- before copying. + let ghcPkgExe = ghcPkgExeName wc + catchAny + (readProcessNull ghcPkgExe + [ "unregister" + , "--force" + , packageIdentifierString taskProvides + ]) + (const (return ())) - readProcessNull Nothing menv' ghcPkgExe - [ "register" - , "--force" - , libpath - ] + void $ proc ghcPkgExe + [ "register" + , "--force" + , libpath + ] + readProcess_ liftIO $ forM_ exes $ \exe -> do D.createDirectoryIfMissing True bindir let dst = bindir FP. FP.takeFileName exe @@ -1315,7 +1337,7 @@ case mlib of Nothing -> return $ Just $ Executable taskProvides Just _ -> do - mpkgid <- loadInstalledPkg eeEnvOverride wc pkgDbs eeSnapshotDumpPkgs pname + mpkgid <- loadInstalledPkg wc pkgDbs eeSnapshotDumpPkgs pname return $ Just $ case mpkgid of @@ -1324,12 +1346,12 @@ where bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix - realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing + realConfigAndBuild cache allDepsMap = withSingleContext ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce _console _mlogFile -> do executableBuildStatuses <- getExecutableBuildStatuses package pkgDir when (not (cabalIsSatisfied executableBuildStatuses) && taskIsTarget task) (logInfo - ("Building all executables for `" <> packageNameText (packageName package) <> + ("Building all executables for `" <> RIO.display (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 task @@ -1390,9 +1412,9 @@ -- https://github.com/commercialhaskell/stack/issues/2649 -- is resolved, we will want to partition the warnings -- based on variety, and output in different lists. - let showModuleWarning (UnlistedModulesWarning mcomp modules) = + let showModuleWarning (UnlistedModulesWarning comp modules) = "- In" <+> - maybe "the library component" (\c -> fromString c <+> "component") mcomp <> + fromString (T.unpack (renderComponent comp)) <> ":" <> line <> indent 4 (mconcat $ intersperse line $ map (styleGood . fromString . C.display) modules) forM_ mlocalWarnings $ \(cabalfp, warnings) -> do @@ -1425,14 +1447,21 @@ announce "haddock" sourceFlag <- if not (boptsHaddockHyperlinkSource eeBuildOpts) then return [] else do -- See #2429 for why the temp dir is used - hyped <- tryProcessStdout (Just eeTempDir) eeEnvOverride "haddock" ["--hyperlinked-source"] - case hyped of + ec + <- withWorkingDir (toFilePath eeTempDir) + $ proc "haddock" ["--hyperlinked-source"] + $ \pc -> withProcess + (setStdout createSource $ setStderr createSource pc) $ \p -> + runConcurrently + $ Concurrently (runConduit $ getStdout p .| CL.sinkNull) + *> Concurrently (runConduit $ getStderr p .| CL.sinkNull) + *> Concurrently (waitExitCode p) + case ec of -- Fancy crosslinked source - Right _ -> do - return ["--haddock-option=--hyperlinked-source"] + ExitSuccess -> return ["--haddock-option=--hyperlinked-source"] -- Older hscolour colouring - Left _ -> do - hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" + ExitFailure _ -> do + hscolourExists <- doesExecutableExist "HsColour" unless hscolourExists $ logWarn ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> "found on PATH (use 'stack install hscolour' to install).") @@ -1455,7 +1484,7 @@ eres <- try $ cabal KeepTHLoading ["copy"] case eres of Left err@CabalExitedUnsuccessfully{} -> - throwM $ CabalCopyFailed (packageBuildType package == Just C.Simple) (show err) + throwM $ CabalCopyFailed (packageBuildType package == C.Simple) (show err) _ -> return () when hasLibrary $ cabal KeepTHLoading ["register"] @@ -1470,7 +1499,7 @@ let ident = PackageIdentifier (packageName package) (packageVersion package) mpkgid <- case packageLibraries package of HasLibraries _ -> do - mpkgid <- loadInstalledPkg eeEnvOverride wc [installedPkgDb] installedDumpPkgsTVar (packageName package) + mpkgid <- loadInstalledPkg wc [installedPkgDb] installedDumpPkgsTVar (packageName package) case mpkgid of Nothing -> throwM $ Couldn'tFindPkgId $ packageName package Just pkgid -> return $ Library ident pkgid Nothing @@ -1499,8 +1528,8 @@ return mpkgid - loadInstalledPkg menv wc pkgDbs tvar name = do - dps <- ghcPkgDescribe name menv wc pkgDbs $ conduitDumpPackage =$ CL.consume + loadInstalledPkg wc pkgDbs tvar name = do + dps <- ghcPkgDescribe name wc pkgDbs $ conduitDumpPackage .| CL.consume case dps of [] -> return Nothing [dp] -> do @@ -1527,12 +1556,12 @@ -- | Check whether the given executable is defined in the given dist directory. checkExeStatus - :: (MonadLogger m, MonadIO m, MonadThrow m) + :: HasLogFunc env => WhichCompiler -> Platform -> Path b Dir -> Text - -> m (Text, ExecutableBuildStatus) + -> RIO env (Text, ExecutableBuildStatus) checkExeStatus compiler platform distDir name = do exename <- parseRelDir (T.unpack name) exists <- checkPath (distDir $(mkRelDir "build") exename) @@ -1587,19 +1616,18 @@ -- | Implements running a package's tests. Also handles producing -- coverage reports if coverage is enabled. singleTest :: HasEnvConfig env - => (RIO env () -> IO ()) - -> TestOpts + => TestOpts -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> RIO env () -singleTest runInBase topts testsToRun ac ee task installedMap = do +singleTest topts testsToRun ac ee task installedMap = do -- FIXME: Since this doesn't use cabal, we should be able to avoid using a -- fullblown 'withSingleContext'. (allDepsMap, _cache) <- getConfigCache ee task installedMap True False - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do + withSingleContext ac ee task (Just allDepsMap) (Just "test") $ \package _cabalfp pkgDir _cabal announce _console mlogFile -> do config <- view configL let needHpc = toCoverage topts @@ -1645,20 +1673,20 @@ tixPath <- liftM (pkgDir ) $ parseRelFile $ exeName ++ ".tix" exePath <- liftM (buildDir ) $ parseRelFile $ "build/" ++ testName' ++ "/" ++ exeName exists <- doesFileExist exePath - menv <- liftIO $ configEnvOverride config EnvSettings + menv <- liftIO $ configProcessContextSettings config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True , esStackExe = True , esLocaleUtf8 = False , esKeepGhcRts = False } - if exists + withProcessContext menv $ if exists then do -- We clear out the .tix files before doing a run. when needHpc $ do tixexists <- doesFileExist tixPath when tixexists $ - logWarn ("Removing HPC file " <> T.pack (toFilePath tixPath)) + logWarn ("Removing HPC file " <> fromString (toFilePath tixPath)) liftIO $ ignoringAbsence (removeFile tixPath) let args = toAdditionalArgs topts @@ -1674,22 +1702,23 @@ liftIO $ hFlush stdout liftIO $ hFlush stderr - let output = + let output setter = case mlogFile of - Nothing -> Inherit - Just (_, h) -> UseHandle h + Nothing -> id + Just (_, h) -> setter (useHandleOpen h) - -- Use createProcess_ to avoid the log file being closed afterwards - (Just inH, Nothing, Nothing, ph) <- createProcess' - stestName - (\cp -> cp { std_in = CreatePipe, std_out = output, std_err = output }) - (Cmd (Just pkgDir) (toFilePath exePath) menv args) - when isTestTypeLib $ do - logPath <- buildLogPath package (Just stestName) - ensureDir (parent logPath) - liftIO $ hPutStr inH $ show (logPath, testName) - liftIO $ hClose inH - ec <- liftIO $ waitForProcess ph + ec <- withWorkingDir (toFilePath pkgDir) $ + proc (toFilePath exePath) args $ \pc0 -> do + let pc = setStdin createPipe + $ output setStdout + $ output setStderr + pc0 + withProcess pc $ \p -> do + when isTestTypeLib $ do + logPath <- buildLogPath package (Just stestName) + ensureDir (parent logPath) + liftIO $ hPutStr (getStdin p) $ show (logPath, testName) + waitExitCode p -- Add a trailing newline, incase the test -- output didn't finish with a newline. when (isNothing mlogFile) (logInfo "") @@ -1707,8 +1736,8 @@ announceResult "failed" return $ Map.singleton testName (Just ec) else do - logError $ T.pack $ show $ TestSuiteExeMissing - (packageBuildType package == Just C.Simple) + logError $ displayShow $ TestSuiteExeMissing + (packageBuildType package == C.Simple) exeName (packageNameString (packageName package)) (T.unpack testName) @@ -1739,17 +1768,16 @@ -- | Implements running a package's benchmarks. singleBench :: HasEnvConfig env - => (RIO env () -> IO ()) - -> BenchmarkOpts + => BenchmarkOpts -> [Text] -> ActionContext -> ExecuteEnv -> Task -> InstalledMap -> RIO env () -singleBench runInBase beopts benchesToRun ac ee task installedMap = do +singleBench beopts benchesToRun ac ee task installedMap = do (allDepsMap, _cache) <- getConfigCache ee task installedMap False True - withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do + withSingleContext ac ee task (Just allDepsMap) (Just "bench") $ \_package _cabalfp _pkgDir cabal announce _console _mlogFile -> do let args = map T.unpack benchesToRun <> maybe [] ((:[]) . ("--benchmark-options=" <>)) (beoAdditionalArgs beopts) @@ -1778,10 +1806,10 @@ -> ConduitM Text Text m () mungeBuildOutput excludeTHLoading makeAbsolute pkgDir compilerVer = void $ CT.lines - =$ CL.map stripCR - =$ CL.filter (not . isTHLoading) - =$ filterLinkerWarnings - =$ toAbsolute + .| CL.map stripCR + .| CL.filter (not . isTHLoading) + .| filterLinkerWarnings + .| toAbsolute where -- | Is this line a Template Haskell "Loading package" line -- ByteString @@ -1911,7 +1939,7 @@ -- Test-suite and benchmark build components. finalComponentOptions :: LocalPackage -> [String] finalComponentOptions lp = - map (T.unpack . decodeUtf8 . renderComponent) $ + map (T.unpack . renderComponent) $ Set.toList $ Set.filter (\c -> isCTest c || isCBench c) (lpComponents lp) diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -20,10 +20,8 @@ import Stack.Prelude import qualified Data.Foldable as F import qualified Data.HashSet as HS -import Data.List.Extra (nubOrd) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import qualified Data.Text as T import Data.Time (UTCTime) import Path import Path.Extra @@ -39,7 +37,7 @@ import Stack.Types.PackageName import Stack.Types.Runner import qualified System.FilePath as FP -import System.Process.Read +import RIO.Process import Web.Browser (openBrowser) openHaddocksInBrowser @@ -78,11 +76,11 @@ else do logWarn $ "Expected to find documentation at " <> - T.pack (toFilePath docFile) <> + fromString (toFilePath docFile) <> ", but that file is missing. Opening doc index instead." getDocIndex _ -> getDocIndex - prettyInfo $ "Opening" <+> display docFile <+> "in the browser." + prettyInfo $ "Opening" <+> Stack.PrettyPrint.display docFile <+> "in the browser." _ <- liftIO $ openBrowser (toFilePath docFile) return () @@ -104,14 +102,13 @@ -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local package dump -> [LocalPackage] - -> m () -generateLocalHaddockIndex envOverride wc bco localDumpPkgs locals = do + -> RIO env () +generateLocalHaddockIndex wc bco localDumpPkgs locals = do let dumpPackages = mapMaybe (\LocalPackage{lpPackage = Package{..}} -> @@ -121,7 +118,6 @@ locals generateHaddockIndex "local packages" - envOverride wc bco dumpPackages @@ -130,21 +126,19 @@ -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global dump information -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot dump information -> Map GhcPkgId (DumpPackage () () ()) -- ^ Local dump information -> [LocalPackage] - -> m () -generateDepsHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do + -> RIO env () +generateDepsHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs localDumpPkgs locals = do let deps = (mapMaybe (`lookupDumpPackage` allDumpPkgs) . nubOrd . findTransitiveDepends . mapMaybe getGhcPkgId) locals depDocDir = localDepsDocDir bco generateHaddockIndex "local packages and dependencies" - envOverride wc bco deps @@ -175,17 +169,15 @@ -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> BaseConfigOpts -> Map GhcPkgId (DumpPackage () () ()) -- ^ Global package dump -> Map GhcPkgId (DumpPackage () () ()) -- ^ Snapshot package dump - -> m () -generateSnapHaddockIndex envOverride wc bco globalDumpPkgs snapshotDumpPkgs = + -> RIO env () +generateSnapHaddockIndex wc bco globalDumpPkgs snapshotDumpPkgs = generateHaddockIndex "snapshot packages" - envOverride wc bco (Map.elems snapshotDumpPkgs ++ Map.elems globalDumpPkgs) @@ -194,16 +186,15 @@ -- | Generate Haddock index and contents for specified packages. generateHaddockIndex - :: (MonadUnliftIO m, MonadLogger m) + :: (HasProcessContext env, HasLogFunc env) => Text - -> EnvOverride -> WhichCompiler -> BaseConfigOpts -> [DumpPackage () () ()] -> FilePath -> Path Abs Dir - -> m () -generateHaddockIndex descr envOverride wc bco dumpPackages docRelFP destDir = do + -> RIO env () +generateHaddockIndex descr wc bco dumpPackages docRelFP destDir = do ensureDir destDir interfaceOpts <- (liftIO . fmap nubOrd . mapMaybeM toInterfaceOpt) dumpPackages unless (null interfaceOpts) $ do @@ -216,13 +207,13 @@ or [mt > indexModTime | (_,mt,_,_) <- interfaceOpts] if needUpdate then do - logInfo - (T.concat ["Updating Haddock index for ", descr, " in\n", - T.pack (toFilePath destIndexFile)]) + logInfo $ + "Updating Haddock index for " <> + Stack.Prelude.display descr <> + " in\n" <> + fromString (toFilePath destIndexFile) liftIO (mapM_ copyPkgDocs interfaceOpts) - readProcessNull - (Just destDir) - envOverride + withWorkingDir (toFilePath destDir) $ readProcessNull (haddockExeName wc) (map (("--optghc=-package-db=" ++ ) . toFilePathNoTrailingSep) [bcoSnapDB bco, bcoLocalDB bco] ++ @@ -230,9 +221,11 @@ ["--gen-contents", "--gen-index"] ++ [x | (xs,_,_,_) <- interfaceOpts, x <- xs]) else - logInfo - (T.concat ["Haddock index for ", descr, " already up to date at:\n", - T.pack (toFilePath destIndexFile)]) + logInfo $ + "Haddock index for " <> + Stack.Prelude.display descr <> + " already up to date at:\n" <> + fromString (toFilePath destIndexFile) where toInterfaceOpt :: DumpPackage a b c -> IO (Maybe ([String], UTCTime, Path Abs File, Path Abs File)) toInterfaceOpt DumpPackage {..} = diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -18,7 +18,6 @@ import Data.List import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map -import qualified Data.Text as T import Path import Stack.Build.Cache import Stack.Constants @@ -33,7 +32,6 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read (EnvOverride) -- | Options for 'getInstalled'. data GetInstalledOpts = GetInstalledOpts @@ -47,8 +45,7 @@ -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: HasEnvConfig env - => EnvOverride - -> GetInstalledOpts + => GetInstalledOpts -> Map PackageName PackageSource -- ^ does not contain any installed information -> RIO env ( InstalledMap @@ -56,7 +53,7 @@ , [DumpPackage () () ()] -- snapshot installed , [DumpPackage () () ()] -- locally installed ) -getInstalled menv opts sourceMap = do +getInstalled opts sourceMap = do logDebug "Finding out which packages are already installed" snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal @@ -67,7 +64,7 @@ then configInstalledCache >>= liftM Just . loadInstalledCache else return Nothing - let loadDatabase' = loadDatabase menv opts mcache sourceMap + let loadDatabase' = loadDatabase opts mcache sourceMap (installedLibs0, globalDumpPkgs) <- loadDatabase' Nothing [] (installedLibs1, _extraInstalled) <- @@ -118,17 +115,16 @@ -- that it has profiling if necessary, and that it matches the version and -- location needed by the SourceMap loadDatabase :: HasEnvConfig env - => EnvOverride - -> GetInstalledOpts + => GetInstalledOpts -> Maybe InstalledCache -- ^ if Just, profiling or haddock is required -> Map PackageName PackageSource -- ^ to determine which installed things we should include -> Maybe (InstalledPackageLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases -> RIO env ([LoadHelper], [DumpPackage () () ()]) -loadDatabase menv opts mcache sourceMap mdb lhs0 = do +loadDatabase opts mcache sourceMap mdb lhs0 = do wc <- view $ actualCompilerVersionL.to whichCompiler - (lhs1', dps) <- ghcPkgDump menv wc (fmap snd (maybeToList mdb)) - $ conduitDumpPackage =$ sink + (lhs1', dps) <- ghcPkgDump wc (fmap snd (maybeToList mdb)) + $ conduitDumpPackage .| sink let ghcjsHack = wc == Ghcjs && isNothing mdb lhs1 <- mapMaybeM (processLoadResult mdb ghcjsHack) lhs1' let lhs = pruneDeps @@ -159,54 +155,50 @@ _ -> CL.map (\dp -> dp { dpSymbols = False }) mloc = fmap fst mdb sinkDP = conduitProfilingCache - =$ conduitHaddockCache - =$ conduitSymbolsCache - =$ CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) - =$ CL.consume + .| conduitHaddockCache + .| conduitSymbolsCache + .| CL.map (isAllowed opts mcache sourceMap mloc &&& toLoadHelper mloc) + .| CL.consume sink = getZipSink $ (,) <$> ZipSink sinkDP <*> ZipSink CL.consume -processLoadResult :: MonadLogger m +processLoadResult :: HasLogFunc env => Maybe (InstalledPackageLocation, Path Abs Dir) -> Bool -> (Allowed, LoadHelper) - -> m (Maybe LoadHelper) + -> RIO env (Maybe LoadHelper) processLoadResult _ _ (Allowed, lh) = return (Just lh) processLoadResult _ True (WrongVersion actual wanted, lh) -- Allow some packages in the ghcjs global DB to have the wrong -- versions. Treat them as wired-ins by setting deps to []. | fst (lhPair lh) `HashSet.member` ghcjsBootPackages = do - logWarn $ T.concat - [ "Ignoring that the GHCJS boot package \"" - , packageNameText (fst (lhPair lh)) - , "\" has a different version, " - , versionText actual - , ", than the resolver's wanted version, " - , versionText wanted - ] + logWarn $ + "Ignoring that the GHCJS boot package \"" <> + display (packageNameText (fst (lhPair lh))) <> + "\" has a different version, " <> + display (versionText actual) <> + ", than the resolver's wanted version, " <> + display (versionText wanted) return (Just lh) processLoadResult mdb _ (reason, lh) = do - logDebug $ T.concat $ - [ "Ignoring package " - , packageNameText (fst (lhPair lh)) - ] ++ - maybe [] (\db -> [", from ", T.pack (show db), ","]) mdb ++ - [ " due to" - , case reason of + logDebug $ + "Ignoring package " <> + display (packageNameText (fst (lhPair lh))) <> + maybe mempty (\db -> ", from " <> displayShow db <> ",") mdb <> + " due to" <> + case reason of Allowed -> " the impossible?!?!" NeedsProfiling -> " it needing profiling." NeedsHaddock -> " it needing haddocks." NeedsSymbols -> " it needing debugging symbols." UnknownPkg -> " it being unknown to the resolver / extra-deps." - WrongLocation mloc loc -> " wrong location: " <> T.pack (show (mloc, loc)) - WrongVersion actual wanted -> T.concat - [ " wanting version " - , versionText wanted - , " instead of " - , versionText actual - ] - ] + WrongLocation mloc loc -> " wrong location: " <> displayShow (mloc, loc) + WrongVersion actual wanted -> + " wanting version " <> + display (versionText wanted) <> + " instead of " <> + display (versionText actual) return Nothing data Allowed @@ -238,25 +230,37 @@ | otherwise = case Map.lookup name sourceMap of Nothing -> - case mloc of - -- The sourceMap has nothing to say about this global - -- package, so we can use it - Nothing -> Allowed - Just ExtraGlobal -> Allowed - -- For non-global packages, don't include unknown packages. - -- See: - -- https://github.com/commercialhaskell/stack/issues/292 - Just _ -> UnknownPkg - Just pii - | not (checkLocation (piiLocation pii)) -> WrongLocation mloc (piiLocation pii) - | version /= piiVersion pii -> WrongVersion version (piiVersion pii) - | otherwise -> Allowed + -- If the sourceMap has nothing to say about this package, + -- check if it represents a sublibrary first + -- See: https://github.com/commercialhaskell/stack/issues/3899 + case dpParentLibIdent dp of + Just (PackageIdentifier parentLibName version') -> + case Map.lookup parentLibName sourceMap of + Nothing -> checkNotFound + Just pii + | version' == version -> checkFound pii + | otherwise -> checkNotFound -- different versions + Nothing -> checkNotFound + Just pii -> checkFound pii where PackageIdentifier name version = dpPackageIdent dp -- Ensure that the installed location matches where the sourceMap says it -- should be installed checkLocation Snap = mloc /= Just (InstalledTo Local) -- we can allow either global or snap checkLocation Local = mloc == Just (InstalledTo Local) || mloc == Just ExtraGlobal -- 'locally' installed snapshot packages can come from extra dbs + -- Check if a package is allowed if it is found in the sourceMap + checkFound pii + | not (checkLocation (piiLocation pii)) = WrongLocation mloc (piiLocation pii) + | version /= piiVersion pii = WrongVersion version (piiVersion pii) + | otherwise = Allowed + -- check if a package is allowed if it is not found in the sourceMap + checkNotFound = case mloc of + -- The sourceMap has nothing to say about this global package, so we can use it + Nothing -> Allowed + Just ExtraGlobal -> Allowed + -- For non-global packages, don't include unknown packages. + -- See: https://github.com/commercialhaskell/stack/issues/292 + Just _ -> UnknownPkg data LoadHelper = LoadHelper { lhId :: !GhcPkgId @@ -278,7 +282,7 @@ if name `HashSet.member` wiredInPackages then [] else dpDepends dp - , lhPair = (name, (toPackageLocation mloc, Library ident gid (dpLicense dp))) + , lhPair = (name, (toPackageLocation mloc, Library ident gid (Right <$> dpLicense dp))) } where gid = dpGhcPkgId dp diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -20,8 +20,7 @@ import Crypto.Hash.Conduit (sinkHash) import qualified Data.ByteArray as Mem (convert) import qualified Data.ByteString as S -import Data.Conduit (($$), ZipSink (..)) -import qualified Data.Conduit.Binary as CB +import Data.Conduit (ZipSink (..)) import qualified Data.Conduit.List as CL import qualified Data.HashSet as HashSet import Data.List @@ -38,6 +37,7 @@ import Stack.Types.BuildPlan import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageName import qualified System.Directory as D @@ -167,6 +167,7 @@ where go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c []) go a b c (CLib:xs) = go a b c xs + go a b c (CInternalLib x:xs) = go (a . (x:)) b c xs go a b c (CExe x:xs) = go (a . (x:)) b c xs go a b c (CTest x:xs) = go a (b . (x:)) c xs go a b c (CBench x:xs) = go a b (c . (x:)) xs @@ -421,9 +422,7 @@ Nothing -> return Map.empty Just modTime' -> if modTime' < preBuildTime - then do - newFci <- calcFci modTime' fp - return (Map.singleton fp newFci) + then Map.singleton fp <$> calcFci modTime' fp else return Map.empty -- | Gets list of Paths for files relevant to a set of components in a package. @@ -436,9 +435,9 @@ -> Set NamedComponent -> RIO env (Map NamedComponent (Set (Path Abs File)), [PackageWarning]) getPackageFilesForTargets pkg cabalFP nonLibComponents = do - (_,compFiles,otherFiles,warnings) <- + (components',compFiles,otherFiles,warnings) <- getPackageFiles (packageFiles pkg) cabalFP - let components = Set.insert CLib nonLibComponents + let components = M.keysSet components' `Set.union` nonLibComponents componentsFiles = M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath files)) $ M.filterWithKey (\component _ -> component `Set.member` components) compFiles @@ -460,8 +459,8 @@ -- | Create FileCacheInfo for a file. calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo calcFci modTime' fp = liftIO $ - withBinaryFile fp ReadMode $ \h -> do - (size, digest) <- CB.sourceHandle h $$ getZipSink + withSourceFile fp $ \src -> do + (size, digest) <- runConduit $ src .| getZipSink ((,) <$> ZipSink (CL.fold (\x y -> x + fromIntegral (S.length y)) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -79,11 +79,11 @@ import Path.Extra (rejectMissingDir) import Path.IO import Stack.Config (getLocalPackages) -import Stack.Fetch (withCabalLoader) import Stack.PackageIndex import Stack.PackageLocation import Stack.Snapshot (calculatePackagePromotion) import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version @@ -230,6 +230,7 @@ -- Helper function: check if a 'NamedComponent' matches the given 'ComponentName' isCompNamed :: ComponentName -> NamedComponent -> Bool isCompNamed _ CLib = False + isCompNamed t1 (CInternalLib t2) = t1 == t2 isCompNamed t1 (CExe t2) = t1 == t2 isCompNamed t1 (CTest t2) = t1 == t2 isCompNamed t1 (CBench t2) = t1 == t2 @@ -340,9 +341,8 @@ , rrPackageType = Dependency } where - getLatestVersion pn = do - vs <- getPackageVersions pn - return (fmap fst (Set.maxView vs)) + getLatestVersion pn = + fmap fst . Set.maxView <$> getPackageVersions pn go (RTPackageIdentifier ident@(PackageIdentifier name version)) | Map.member name locals = return $ Left $ T.concat @@ -413,9 +413,9 @@ deriving (Eq, Show) combineResolveResults - :: forall m. MonadLogger m + :: forall env. HasLogFunc env => [ResolveResult] - -> m ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) + -> RIO env ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath)) combineResolveResults results = do addedDeps <- fmap Map.unions $ forM results $ \result -> case rrAddedDep result of @@ -509,9 +509,9 @@ drops = Set.empty -- not supported to add drops - (globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do + (globals', snapshots, locals') <- do addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do - gpd <- parseSingleCabalFileIndex loadFromIndex root loc + gpd <- parseSingleCabalFileIndex root loc return (name, (gpd, loc, Nothing)) -- Calculate a list of all of the locals, based on the project @@ -532,7 +532,7 @@ ] calculatePackagePromotion - loadFromIndex root ls0 (Map.elems allLocals) + root ls0 (Map.elems allLocals) flags hides options drops let ls = LoadedSnapshot diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -24,7 +24,7 @@ , showItems ) where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.List (intercalate) @@ -43,11 +43,13 @@ import Distribution.System (Platform) import Distribution.Text (display) import qualified Distribution.Version as C +import qualified RIO import Stack.Constants import Stack.Package import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version @@ -428,9 +430,9 @@ -> RIO env (SnapshotDef, BuildPlanCheck) selectBestSnapshot root gpds snaps = do logInfo $ "Selecting the best among " - <> T.pack (show (NonEmpty.length snaps)) + <> displayShow (NonEmpty.length snaps) <> " snapshots...\n" - F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverSnapshot) snaps) + F.foldr1 go (NonEmpty.map (getResult <=< loadResolver . ResolverStackage) snaps) where go mold mnew = do old@(_snap, bpc) <- mold @@ -440,7 +442,7 @@ getResult snap = do result <- checkSnapBuildPlan root gpds Nothing snap - -- We know that we're only dealing with ResolverSnapshot + -- We know that we're only dealing with ResolverStackage -- here, where we can rely on the global package hints. -- Therefore, we don't use an actual compiler. For more -- info, see comments on @@ -454,16 +456,16 @@ | otherwise = (s2, r2) reportResult BuildPlanCheckOk {} snap = do - logInfo $ "* Matches " <> sdResolverName snap + logInfo $ "* Matches " <> RIO.display (sdResolverName snap) logInfo "" reportResult r@BuildPlanCheckPartial {} snap = do - logWarn $ "* Partially matches " <> sdResolverName snap - logWarn $ indent $ T.pack $ show r + logWarn $ "* Partially matches " <> RIO.display (sdResolverName snap) + logWarn $ RIO.display $ indent $ T.pack $ show r reportResult r@BuildPlanCheckFail {} snap = do - logWarn $ "* Rejected " <> sdResolverName snap - logWarn $ indent $ T.pack $ show r + logWarn $ "* Rejected " <> RIO.display (sdResolverName snap) + logWarn $ RIO.display $ indent $ T.pack $ show r indent t = T.unlines $ fmap (" " <>) (T.lines t) diff --git a/src/Stack/Clean.hs b/src/Stack/Clean.hs --- a/src/Stack/Clean.hs +++ b/src/Stack/Clean.hs @@ -14,7 +14,6 @@ import Stack.Prelude import Data.List ((\\),intercalate) import qualified Data.Map.Strict as Map -import qualified Data.Text as T import Path.IO (ignoringAbsence, removeDirRecur) import Stack.Config (getLocalPackages) import Stack.Constants.Config (distDirFromDir, workDirFromDir) @@ -32,7 +31,7 @@ where cleanDir dir = liftIO (ignoringAbsence (removeDirRecur dir) >> return False) `catchAny` \ex -> do - logError $ "Exception while recursively deleting " <> T.pack (toFilePath dir) <> "\n" <> T.pack (show ex) + logError $ "Exception while recursively deleting " <> fromString (toFilePath dir) <> "\n" <> displayShow ex logError "Perhaps you do not have permission to delete these files or they are in use?" return True diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -61,9 +61,10 @@ import qualified Distribution.Text import Distribution.Version (simplifyVersionRange, mkVersion') import GHC.Conc (getNumProcessors) -import Lens.Micro (lens) +import Lens.Micro (lens, set) import Network.HTTP.Client (parseUrlThrow) -import Network.HTTP.Simple (httpJSON, getResponseBody) +import Network.HTTP.StackClient (httpJSON) +import Network.HTTP.Simple (getResponseBody) import Options.Applicative (Parser, strOption, long, help) import Path import Path.Extra (toFilePathNoTrailingSep) @@ -75,9 +76,9 @@ import Stack.Config.Nix import Stack.Config.Urls import Stack.Constants -import Stack.Fetch import qualified Stack.Image as Image import Stack.PackageLocation +import Stack.PackageIndex (CabalLoader (..), HasCabalLoader (..)) import Stack.Snapshot import Stack.Types.BuildPlan import Stack.Types.Compiler @@ -94,17 +95,17 @@ import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) -import System.Process.Read +import RIO.Process -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. tryDeprecatedPath - :: (MonadIO m, MonadLogger m) + :: HasLogFunc env => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed) - -> (Path Abs a -> m Bool) -- ^ Test for existence + -> (Path Abs a -> RIO env Bool) -- ^ Test for existence -> Path Abs a -- ^ New path -> Path Abs a -- ^ Deprecated path - -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) + -> RIO env (Path Abs a, Bool) -- ^ (Path to use, whether it already exists) tryDeprecatedPath mWarningDesc exists new old = do newExists <- exists new if newExists @@ -116,12 +117,12 @@ case mWarningDesc of Nothing -> return () Just desc -> - logWarn $ T.concat - [ "Warning: Location of ", desc, " at '" - , T.pack (toFilePath old) - , "' is deprecated; rename it to '" - , T.pack (toFilePath new) - , "' instead" ] + logWarn $ + "Warning: Location of " <> display desc <> " at '" <> + fromString (toFilePath old) <> + "' is deprecated; rename it to '" <> + fromString (toFilePath new) <> + "' instead" return (old, True) else return (new, False) @@ -129,8 +130,8 @@ -- If the directory already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getImplicitGlobalProjectDir - :: (MonadIO m, MonadLogger m) - => Config -> m (Path Abs Dir) + :: HasLogFunc env + => Config -> RIO env (Path Abs Dir) getImplicitGlobalProjectDir config = --TEST no warning printed liftM fst $ tryDeprecatedPath @@ -139,7 +140,7 @@ (implicitGlobalProjectDir stackRoot) (implicitGlobalProjectDirDeprecated stackRoot) where - stackRoot = configStackRoot config + stackRoot = view stackRootL config -- | This is slightly more expensive than @'asks' ('bcStackYaml' '.' 'getBuildConfig')@ -- and should only be used when no 'BuildConfig' is at hand. @@ -155,7 +156,7 @@ getSnapshots = do latestUrlText <- askLatestSnapshotUrl latestUrl <- parseUrlThrow (T.unpack latestUrlText) - logDebug $ "Downloading snapshot versions file from " <> latestUrlText + logDebug $ "Downloading snapshot versions file from " <> display latestUrlText result <- httpJSON latestUrl logDebug "Done downloading and parsing snapshot versions file" return $ getResponseBody result @@ -179,17 +180,17 @@ ProjectAndConfigMonoid project _ <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp return $ projectResolver project - ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots + ARLatestNightly -> return $ ResolverStackage $ Nightly $ snapshotsNightly snapshots ARLatestLTSMajor x -> case IntMap.lookup x $ snapshotsLts snapshots of Nothing -> throwString $ "No LTS release found with major version " ++ show x - Just y -> return $ ResolverSnapshot $ LTS x y + Just y -> return $ ResolverStackage $ LTS x y ARLatestLTS | IntMap.null $ snapshotsLts snapshots -> throwString "No LTS releases found" | otherwise -> let (x, y) = IntMap.findMax $ snapshotsLts snapshots - in return $ ResolverSnapshot $ LTS x y - logInfo $ "Selected resolver: " <> resolverRawName r + in return $ ResolverStackage $ LTS x y + logInfo $ "Selected resolver: " <> display (resolverRawName r) return r -- | Get the latest snapshot resolver available. @@ -200,16 +201,16 @@ (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) return (LTS x y) snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts - return (ResolverSnapshot snap) + return (ResolverStackage snap) -- | Create a 'Config' value when we're not using any local -- configuration files (e.g., the script command) configNoLocalConfig - :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) + :: HasRunner env => Path Abs Dir -- ^ stack root -> Maybe AbstractResolver -> ConfigMonoid - -> m Config + -> RIO env Config configNoLocalConfig _ Nothing _ = throwIO NoResolverWhenUsingNoLocalConfig configNoLocalConfig stackRoot (Just resolver) configMonoid = do userConfigPath <- liftIO $ getFakeConfigPath stackRoot resolver @@ -223,16 +224,16 @@ -- Interprets ConfigMonoid options. configFromConfigMonoid - :: (MonadLogger m, MonadUnliftIO m, MonadThrow m, MonadReader env m, HasRunner env) + :: HasRunner env => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Bool -- ^ allow locals? -> Maybe AbstractResolver -> Maybe (Project, Path Abs File) -> ConfigMonoid - -> m Config + -> RIO env Config configFromConfigMonoid - configStackRoot configUserConfigPath configAllowLocals mresolver + clStackRoot configUserConfigPath configAllowLocals mresolver mproject ConfigMonoid{..} = do -- If --stack-work is passed, prefer it. Otherwise, if STACK_WORK -- is set, use that. If neither, use the default ".stack-work" @@ -245,9 +246,9 @@ logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration" return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url } _ -> return (urlsFromMonoid configMonoidUrls) - let configConnectionCount = fromFirst 8 configMonoidConnectionCount + let clConnectionCount = fromFirst 8 configMonoidConnectionCount configHideTHLoading = fromFirst True configMonoidHideTHLoading - configPackageIndices = fromFirst + clIndices = fromFirst [PackageIndex { indexName = IndexName "Hackage" , indexLocation = "https://s3.amazonaws.com/hackage.fpcomplete.com/" @@ -280,7 +281,7 @@ configExtraLibDirs = configMonoidExtraLibDirs configOverrideGccPath = getFirst configMonoidOverrideGccPath configOverrideHpack = maybe HpackBundled HpackCommand $ getFirst configMonoidOverrideHpack - + -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform @@ -296,7 +297,8 @@ configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck case arch of - OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> T.pack (show unk) + OtherArch "aarch64" -> return () + OtherArch unk -> logWarn $ "Warning: Unknown value for architecture setting: " <> displayShow unk _ -> return () configPlatformVariant <- liftIO $ @@ -304,7 +306,7 @@ let configBuild = buildOptsFromMonoid configMonoidBuildOpts configDocker <- - dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts + dockerOptsFromMonoid (fmap fst mproject) clStackRoot mresolver configMonoidDockerOpts configNix <- nixOptsFromMonoid configMonoidNixOpts os configSystemGHC <- @@ -321,13 +323,14 @@ throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC rawEnv <- liftIO getEnvironment - pathsEnv <- augmentPathMap configMonoidExtraPath + pathsEnv <- either throwM return + $ augmentPathMap (map toFilePath configMonoidExtraPath) (Map.fromList (map (T.pack *** T.pack) rawEnv)) - origEnv <- mkEnvOverride configPlatform pathsEnv - let configEnvOverride _ = return origEnv + origEnv <- mkProcessContext pathsEnv + let configProcessContextSettings _ = return origEnv configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of - Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv + Nothing -> getDefaultLocalProgramsBase clStackRoot configPlatform origEnv Just path -> return path platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant) let configLocalPrograms = configLocalProgramsBase platformOnlyDir @@ -369,26 +372,30 @@ configDefaultTemplate = getFirst configMonoidDefaultTemplate configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds - configIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch + clIgnoreRevisionMismatch = fromFirst False configMonoidIgnoreRevisionMismatch configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of Just True -> return True _ -> getInContainer - configPackageCache <- liftIO $ newIORef Nothing - let configMaybeProject = mproject - configRunner <- view runnerL + configRunner' <- view runnerL + clCache <- newIORef Nothing + clUpdateRef <- newMVar True + + let configRunner = set processContextL origEnv configRunner' + configCabalLoader = CabalLoader {..} + return Config {..} -- | Get the default location of the local programs directory. getDefaultLocalProgramsBase :: MonadThrow m => Path Abs Dir -> Platform - -> EnvOverride + -> ProcessContext -> m (Path Abs Dir) getDefaultLocalProgramsBase configStackRoot configPlatform override = let @@ -400,7 +407,7 @@ -- mean that Windows users would manually have to move data from the old -- location to the new one, which is undesirable. Platform _ Windows -> - case Map.lookup "LOCALAPPDATA" $ unEnvOverride override of + case Map.lookup "LOCALAPPDATA" $ view envVarsL override of Just t -> case parseAbsDir $ T.unpack t of Nothing -> throwM $ stringException ("Failed to parse LOCALAPPDATA environment variable (expected absolute directory): " ++ show t) @@ -415,6 +422,10 @@ } instance HasConfig MiniConfig where configL = lens mcConfig (\x y -> x { mcConfig = y }) +instance HasProcessContext MiniConfig where + processContextL = configL.processContextL +instance HasCabalLoader MiniConfig where + cabalLoaderL = configL.cabalLoaderL instance HasPlatform MiniConfig instance HasGHCVariant MiniConfig where ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y }) @@ -532,7 +543,7 @@ ARLatestLTS -> "lts" ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x ARGlobal -> "global" - logDebug ("Using resolver: " <> name <> " specified on command line") + logDebug ("Using resolver: " <> display name <> " specified on command line") -- In order to resolve custom snapshots, we need a base -- directory to deal with relative paths. For the case of @@ -550,7 +561,7 @@ (project', stackYamlFP) <- case mproject of LCSProject (project, fp, _) -> do - forM_ (projectUserMsg project) (logWarn . T.pack) + forM_ (projectUserMsg project) (logWarn . fromString) return (project, fp) LCSNoConfig _ -> do p <- assert (isJust mresolver) (getEmptyProject mresolver) @@ -570,12 +581,15 @@ when (view terminalL config) $ case maresolver of Nothing -> - logDebug ("Using resolver: " <> resolverRawName (projectResolver project) <> - " from implicit global project's config file: " <> T.pack dest') + logDebug $ + "Using resolver: " <> + display (resolverRawName (projectResolver project)) <> + " from implicit global project's config file: " <> + fromString dest' Just _ -> return () return (project, dest) else do - logInfo ("Writing implicit global project config file to: " <> T.pack dest') + logInfo ("Writing implicit global project config file to: " <> fromString dest') logInfo "Note: You can change the snapshot via the resolver field there." p <- getEmptyProject mresolver liftIO $ do @@ -623,11 +637,11 @@ getEmptyProject mresolver = do r <- case mresolver of Just resolver -> do - logInfo ("Using resolver: " <> resolverRawName resolver <> " specified on command line") + logInfo ("Using resolver: " <> display (resolverRawName resolver) <> " specified on command line") return resolver Nothing -> do r'' <- getLatestResolver - logInfo ("Using latest snapshot resolver: " <> resolverRawName r'') + logInfo ("Using latest snapshot resolver: " <> display (resolverRawName r'')) return r'' return Project { projectUserMsg = Nothing @@ -640,14 +654,14 @@ } -- | Get packages from EnvConfig, downloading and cloning as necessary. --- If the packages have already been downloaded, this uses a cached value ( +-- If the packages have already been downloaded, this uses a cached value. getLocalPackages :: forall env. HasEnvConfig env => RIO env LocalPackages getLocalPackages = do cacheRef <- view $ envConfigL.to envConfigPackagesRef mcached <- liftIO $ readIORef cacheRef case mcached of Just cached -> return cached - Nothing -> withCabalLoader $ \loadFromIndex -> do + Nothing -> do root <- view projectRootL bc <- view buildConfigL @@ -661,8 +675,8 @@ $ C.package $ C.packageDescription gpd in (name, (gpd, loc)) - deps <- (map wrapGPD . concat) - <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (bcDependencies bc) + deps <- map wrapGPD . concat + <$> mapM (parseMultiCabalFilesIndex root) (bcDependencies bc) checkDuplicateNames $ map (second (PLOther . lpvLoc)) packages ++ @@ -759,12 +773,6 @@ fileStatus <- getFileStatus (toFilePath path) user <- getEffectiveUserID return (user == fileOwner fileStatus) - where -#ifdef WINDOWS - osIsWindows = True -#else - osIsWindows = False -#endif -- | 'True' if we are currently running inside a Docker container. getInContainer :: (MonadIO m) => m Bool @@ -777,9 +785,9 @@ -- | Determine the extra config file locations which exist. -- -- Returns most local first -getExtraConfigs :: (MonadIO m, MonadLogger m) +getExtraConfigs :: HasLogFunc env => Path Abs File -- ^ use config path - -> m [Path Abs File] + -> RIO env [Path Abs File] getExtraConfigs userConfigPath = do defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath liftIO $ do @@ -797,8 +805,8 @@ -- | Load and parse YAML from the given config file. Throws -- 'ParseConfigFileException' when there's a decoding error. loadConfigYaml - :: (MonadIO m, MonadLogger m) - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m a + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a loadConfigYaml parser path = do eres <- loadYaml parser path case eres of @@ -807,8 +815,8 @@ -- | Load and parse YAML from the given file. loadYaml - :: (MonadIO m, MonadLogger m) - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> m (Either Yaml.ParseException a) + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env (Either Yaml.ParseException a) loadYaml parser path = do eres <- liftIO $ Yaml.decodeFileEither (toFilePath path) case eres of @@ -821,10 +829,10 @@ return (Right res) -- | Get the location of the project config file, if it exists. -getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) +getProjectConfig :: HasLogFunc env => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (LocalConfigStatus (Path Abs File)) + -> RIO env (LocalConfigStatus (Path Abs File)) getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml getProjectConfig SYLDefault = do env <- liftIO getEnvironment @@ -839,7 +847,7 @@ getStackDotYaml dir = do let fp = dir stackDotYaml fp' = toFilePath fp - logDebug $ "Checking for project config at: " <> T.pack fp' + logDebug $ "Checking for project config at: " <> fromString fp' exists <- doesFileExist fp if exists then return $ Just fp @@ -856,17 +864,17 @@ -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. -loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) +loadProjectConfig :: HasLogFunc env => StackYamlLoc (Path Abs File) -- ^ Override stack.yaml - -> m (LocalConfigStatus (Project, Path Abs File, ConfigMonoid)) + -> RIO env (LocalConfigStatus (Project, Path Abs File, ConfigMonoid)) loadProjectConfig mstackYaml = do mfp <- getProjectConfig mstackYaml case mfp of LCSProject fp -> do currDir <- getCurrentDir logDebug $ "Loading project config file " <> - T.pack (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp)) + fromString (maybe (toFilePath fp) toFilePath (stripProperPrefix currDir fp)) LCSProject <$> load fp LCSNoProject -> do logDebug "No project config file found, using defaults." @@ -883,8 +891,8 @@ -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultGlobalConfigPath - :: (MonadIO m, MonadLogger m) - => m (Maybe (Path Abs File)) + :: HasLogFunc env + => RIO env (Maybe (Path Abs File)) getDefaultGlobalConfigPath = case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of (Just new,Just old) -> @@ -901,8 +909,8 @@ -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultUserConfigPath - :: (MonadIO m, MonadLogger m) - => Path Abs Dir -> m (Path Abs File) + :: HasLogFunc env + => Path Abs Dir -> RIO env (Path Abs File) getDefaultUserConfigPath stackRoot = do (path, exists) <- tryDeprecatedPath (Just "non-project configuration file") diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs --- a/src/Stack/Config/Build.hs +++ b/src/Stack/Config/Build.hs @@ -50,6 +50,7 @@ (boptsPreFetch defaultBuildOpts) buildMonoidPreFetch , boptsKeepGoing = getFirst buildMonoidKeepGoing + , boptsKeepTmpFiles = getFirst buildMonoidKeepTmpFiles , boptsForceDirty = fromFirst (boptsForceDirty defaultBuildOpts) buildMonoidForceDirty diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs --- a/src/Stack/Config/Docker.hs +++ b/src/Stack/Config/Docker.hs @@ -41,7 +41,7 @@ Nothing -> "" Just resolver -> case resolver of - ResolverSnapshot n@(LTS _ _) -> + ResolverStackage n@(LTS _ _) -> ":" ++ T.unpack (renderSnapName n) _ -> impureThrow diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -9,20 +9,25 @@ ) where import Stack.Prelude +import Control.Monad.Extra (ifM) import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Distribution.System (OS (..)) +import Stack.Constants import Stack.Types.Version import Stack.Types.Nix import Stack.Types.Compiler +import Stack.Types.Runner +import System.Directory (doesFileExist) -- | Interprets NixOptsMonoid options. nixOptsFromMonoid - :: MonadUnliftIO m + :: HasRunner env => NixOptsMonoid -> OS - -> m NixOpts + -> RIO env NixOpts nixOptsFromMonoid NixOptsMonoid{..} os = do - let nixEnable = fromFirst (getAny nixMonoidDefaultEnable) nixMonoidEnable + let nixEnable0 = fromFirst False nixMonoidEnable defaultPure = case os of OSX -> False _ -> True @@ -32,6 +37,17 @@ nixShellOptions = fromFirst [] nixMonoidShellOptions ++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath) nixAddGCRoots = fromFirst False nixMonoidAddGCRoots + + osIsNixOS <- isNixOS + nixEnable <- case () of _ + | nixEnable0 && osIsWindows -> do + logInfo "Note: Disabling nix integration, since this is being run in Windows" + return False + | not nixEnable0 && osIsNixOS -> do + logInfo "Note: Enabling Nix integration, as it is required under NixOS" + return True + | otherwise -> return nixEnable0 + when (not (null nixPackages) && isJust nixInitFile) $ throwIO NixCannotUseShellFileAndPackagesException return NixOpts{..} @@ -69,3 +85,10 @@ instance Show StackNixException where show NixCannotUseShellFileAndPackagesException = "You cannot have packages and a shell-file filled at the same time in your nix-shell configuration." + +isNixOS :: MonadIO m => m Bool +isNixOS = liftIO $ do + let fp = "/etc/os-release" + ifM (doesFileExist fp) + (T.isInfixOf "ID=nixos" <$> TIO.readFile fp) + (return False) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -70,11 +70,11 @@ config' = HMap.insert cmdKey newValue config if config' == config then logInfo - (T.pack (toFilePath configFilePath) <> + (fromString (toFilePath configFilePath) <> " already contained the intended configuration and remains unchanged.") else do liftIO (S.writeFile (toFilePath configFilePath) (Yaml.encode config')) - logInfo (T.pack (toFilePath configFilePath) <> " has been updated.") + logInfo (fromString (toFilePath configFilePath) <> " has been updated.") cfgCmdSetValue :: (HasConfig env, HasGHCVariant env) @@ -85,10 +85,10 @@ -- Check that the snapshot actually exists void $ loadResolver concreteResolver return (Yaml.toJSON concreteResolver) -cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool) = - return (Yaml.Bool bool) -cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool) = - return (Yaml.Bool bool) +cfgCmdSetValue _ (ConfigCmdSetSystemGhc _ bool') = + return (Yaml.Bool bool') +cfgCmdSetValue _ (ConfigCmdSetInstallGhc _ bool') = + return (Yaml.Bool bool') cfgCmdSetOptionName :: ConfigCmdSet -> Text cfgCmdSetOptionName (ConfigCmdSetResolver _) = "resolver" diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -32,6 +33,7 @@ ,minTerminalWidth ,maxTerminalWidth ,defaultTerminalWidth + ,osIsWindows ) where @@ -241,3 +243,12 @@ -- automatically detect it and when the user doesn't supply one. defaultTerminalWidth :: Int defaultTerminalWidth = 100 + +-- | True if using Windows OS. +osIsWindows :: Bool +osIsWindows = +#ifdef WINDOWS + True +#else + False +#endif diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -106,7 +106,7 @@ -- | Directory for project templates. templatesDir :: Config -> Path Abs Dir -templatesDir config = configStackRoot config $(mkRelDir "templates") +templatesDir config = view stackRootL config $(mkRelDir "templates") -- | Relative location of build artifacts. distRelativeDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -17,12 +18,12 @@ , generateHpcMarkupIndex ) where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import Path @@ -35,14 +36,15 @@ import Stack.PrettyPrint import Stack.Types.Compiler import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.FilePath (isPathSeparator) -import System.Process.Read -import Text.Hastache (htmlEscape) +import qualified RIO +import RIO.Process import Trace.Hpc.Tix import Web.Browser (openBrowser) @@ -65,7 +67,7 @@ -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853 mtix <- readTixOrLog tixSrc case mtix of - Nothing -> logError $ "Failed to read " <> T.pack (toFilePath tixSrc) + Nothing -> logError $ "Failed to read " <> fromString (toFilePath tixSrc) Just tix -> do liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix) -- TODO: ideally we'd do a file move, but IIRC this can @@ -118,7 +120,7 @@ eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) hpcNameField case eincludeName of Left err -> do - logError err + logError $ RIO.display err return $ Left err Right includeName -> return $ Right $ Just $ T.unpack includeName forM_ tests $ \testName -> do @@ -126,7 +128,7 @@ let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\"" reportDir = parent tixSrc case eincludeName of - Left err -> generateHpcErrorReport reportDir (sanitize (T.unpack err)) + Left err -> generateHpcErrorReport reportDir (RIO.display (sanitize (T.unpack err))) -- Restrict to just the current library code, if there is a library in the package (see -- #634 - this will likely be customizable in the future) Right mincludeName -> do @@ -144,20 +146,18 @@ tixFileExists <- doesFileExist tixSrc if not tixFileExists then do - logError $ T.concat - [ "Didn't find .tix for " - , report - , " - expected to find it at " - , T.pack (toFilePath tixSrc) - , "." - ] + logError $ + "Didn't find .tix for " <> + RIO.display report <> + " - expected to find it at " <> + fromString (toFilePath tixSrc) <> + "." return Nothing - else (`catch` \err -> do - let msg = show (err :: ReadProcessException) - logError (T.pack msg) - generateHpcErrorReport reportDir $ sanitize msg + else (`catch` \(err :: ProcessException) -> do + logError $ displayShow err + generateHpcErrorReport reportDir $ RIO.display $ sanitize $ show err return Nothing) $ - (`onException` logError ("Error occurred while producing " <> report)) $ do + (`onException` logError ("Error occurred while producing " <> RIO.display report)) $ do -- Directories for .mix files. hpcRelDir <- hpcRelativeDir -- Compute arguments used for both "hpc markup" and "hpc report". @@ -167,42 +167,42 @@ concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++ -- Look for index files in the correct dir (relative to each pkgdir). ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"] - menv <- getMinimalEnvOverride - logInfo $ "Generating " <> report - outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $ - readProcessStdout Nothing menv "hpc" + logInfo $ "Generating " <> RIO.display report + outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict) $ + proc "hpc" ( "report" : toFilePath tixSrc : (args ++ extraReportArgs) ) + readProcessStdout_ if all ("(0/0)" `S8.isSuffixOf`) outputLines then do - let msg html = T.concat - [ "Error: The " - , report - , " did not consider any code. One possible cause of this is" - , " if your test-suite builds the library code (see stack " - , if html then "" else "" - , "issue #1008" - , if html then "" else "" - , "). It may also indicate a bug in stack or" - , " the hpc program. Please report this issue if you think" - , " your coverage report should have meaningful results." - ] + let msg html = + "Error: The " <> + RIO.display report <> + " did not consider any code. One possible cause of this is" <> + " if your test-suite builds the library code (see stack " <> + (if html then "" else "") <> + "issue #1008" <> + (if html then "" else "") <> + "). It may also indicate a bug in stack or" <> + " the hpc program. Please report this issue if you think" <> + " your coverage report should have meaningful results." logError (msg False) generateHpcErrorReport reportDir (msg True) return Nothing else do let reportPath = reportDir $(mkRelFile "hpc_index.html") -- Print output, stripping @\r@ characters because Windows. - forM_ outputLines (logInfo . T.decodeUtf8) + forM_ outputLines (logInfo . displayBytesUtf8) -- Generate the markup. - void $ readProcessStdout Nothing menv "hpc" + void $ proc "hpc" ( "markup" : toFilePath tixSrc : ("--destdir=" ++ toFilePathNoTrailingSep reportDir) : (args ++ extraMarkupArgs) ) + readProcessStdout_ return (Just reportPath) data HpcReportOpts = HpcReportOpts @@ -223,7 +223,7 @@ then return [] else do when (hroptsAll opts && not (null targetNames)) $ - logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show targetNames) + logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames (_,_,targets) <- parseTargets AllowNoTargets defaultBuildOptsCLI @@ -287,12 +287,11 @@ let tixFiles = tixFiles0 ++ extraTixFiles reportDir = outputDir $(mkRelDir "combined/all") if length tixFiles < 2 - then logInfo $ T.concat - [ if null tixFiles then "No tix files" else "Only one tix file" - , " found in " - , T.pack (toFilePath outputDir) - , ", so not generating a unified coverage report." - ] + then logInfo $ + (if null tixFiles then "No tix files" else "Only one tix file") <> + " found in " <> + fromString (toFilePath outputDir) <> + ", so not generating a unified coverage report." else do let report = "unified report" mreportPath <- generateUnionReport report reportDir tixFiles @@ -303,22 +302,24 @@ -> RIO env (Maybe (Path Abs File)) generateUnionReport report reportDir tixFiles = do (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) - logDebug $ "Using the following tix files: " <> T.pack (show tixFiles) - unless (null errs) $ logWarn $ T.concat $ - "The following modules are left out of the " : report : " due to version mismatches: " : - intersperse ", " (map T.pack errs) + logDebug $ "Using the following tix files: " <> fromString (show tixFiles) + unless (null errs) $ logWarn $ + "The following modules are left out of the " <> + RIO.display report <> + " due to version mismatches: " <> + mconcat (intersperse ", " (map fromString errs)) tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix") ensureDir (parent tixDest) liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] -readTixOrLog :: (MonadLogger m, MonadUnliftIO m) => Path b File -> m (Maybe Tix) +readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix) readTixOrLog path = do mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do - logError $ "Error while reading tix: " <> T.pack (show errorCall) + logError $ "Error while reading tix: " <> fromString (show errorCall) return Nothing when (isNothing mtix) $ - logError $ "Failed to read tix file " <> T.pack (toFilePath path) + logError $ "Failed to read tix file " <> fromString (toFilePath path) return mtix -- | Module names which contain '/' have a package name, and so they weren't built into the @@ -387,23 +388,35 @@ [""] unless (null rows) $ logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> - T.pack (toFilePath outputFile) + fromString (toFilePath outputFile) -generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () +generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m () generateHpcErrorReport dir err = do ensureDir dir - liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat - [ "" - , "

HPC Report Generation Error

" - , "

" - , err - , "

" - , "" - ] + let fp = toFilePath (dir $(mkRelFile "hpc_index.html")) + writeFileUtf8Builder fp $ + "" <> + "

HPC Report Generation Error

" <> + "

" <> + err <> + "

" <> + "" pathToHtml :: Path b t -> Text pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath +-- | Escape HTML symbols (copied from Text.Hastache) +htmlEscape :: LT.Text -> LT.Text +htmlEscape = LT.concatMap proc_ + where + proc_ '&' = "&" + proc_ '\\' = "\" + proc_ '"' = """ + proc_ '\'' = "'" + proc_ '<' = "<" + proc_ '>' = ">" + proc_ h = LT.singleton h + sanitize :: String -> Text sanitize = LT.toStrict . htmlEscape . LT.pack @@ -428,14 +441,14 @@ if cabalVer < $(mkVersion "1.24") then do path <- liftM (inplaceDir ) $ parseRelFile (pkgIdStr ++ "-inplace.conf") - logDebug $ "Parsing config in Cabal < 1.24 location: " <> T.pack (toFilePath path) + logDebug $ "Parsing config in Cabal < 1.24 location: " <> fromString (toFilePath path) exists <- doesFileExist path if exists then extractField path else notFoundErr else do -- With Cabal-1.24, it's in a different location. - logDebug $ "Scanning " <> T.pack (toFilePath inplaceDir) <> " for files matching " <> T.pack pkgIdStr + logDebug $ "Scanning " <> fromString (toFilePath inplaceDir) <> " for files matching " <> fromString pkgIdStr (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir - logDebug $ T.pack (show files) + logDebug $ displayShow files case mapMaybe (\file -> fmap (const file) . (T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))) . T.pack . toFilePath . filename $ file) files of [] -> notFoundErr diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -27,11 +27,13 @@ import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode) import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.Conduit.List (sinkNull) +import Data.Conduit.Process.Typed hiding (proc) import Data.List (dropWhileEnd,intercalate,isPrefixOf,isInfixOf) -import Data.List.Extra (trim, nubOrd) +import Data.List.Extra (trim) import qualified Data.Map.Strict as Map import Data.Ord (Down(..)) import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) @@ -40,6 +42,7 @@ import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Version (showVersion) import GHC.Exts (sortWith) +import Lens.Micro (set) import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (canonicalizePath) @@ -48,6 +51,7 @@ import Stack.Constants import Stack.Constants.Config import Stack.Docker.GlobalDB +import Stack.PackageIndex import Stack.Types.PackageIndex import Stack.Types.Runner import Stack.Types.Version @@ -63,14 +67,11 @@ import System.IO.Unsafe (unsafePerformIO) import qualified System.PosixCompat.User as User import qualified System.PosixCompat.Files as Files -import System.Process (CreateProcess(..), StdStream(..), waitForProcess) import System.Process.PagerEditor (editByteString) -import System.Process.Read -import System.Process.Run +import RIO.Process import Text.Printf (printf) #ifndef WINDOWS -import Control.Concurrent (threadDelay) import System.Posix.Signals import qualified System.Posix.User as PosixUser #endif @@ -93,7 +94,7 @@ reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where - getCmdArgs docker envOverride imageInfo isRemoteDocker = do + getCmdArgs docker imageInfo isRemoteDocker = do config <- view configL deUser <- if fromMaybe (not isRemoteDocker) (dockerSetUser docker) @@ -146,8 +147,6 @@ e <- try $ sinkProcessStderrStdout - Nothing - envOverride "docker" [ "run" , "-v" @@ -237,11 +236,10 @@ runContainerAndExit getCmdArgs mprojectRoot before - after = - do config <- view configL + after = do + config <- view configL let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker + checkDockerVersion docker (env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $ (,,,) <$> getEnvironment @@ -260,13 +258,13 @@ when (isRemoteDocker && maybe False (isInfixOf "boot2docker") dockerCertPath) (logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") - maybeImageInfo <- inspect envOverride image + maybeImageInfo <- inspect image imageInfo@Inspect{..} <- case maybeImageInfo of Just ii -> return ii Nothing | dockerAutoPull docker -> - do pullImage envOverride docker image - mii2 <- inspect envOverride image + do pullImage docker image + mii2 <- inspect image case mii2 of Just ii2 -> return ii2 Nothing -> throwM (InspectFailedException image) @@ -275,7 +273,7 @@ let ImageConfig {..} = iiConfig imageEnvVars = map (break (== '=')) icEnv platformVariant = show $ hashRepoName image - stackRoot = configStackRoot config + stackRoot = view stackRootL config sandboxHomeDir = sandboxDir homeDirName isTerm = not (dockerDetach docker) && isStdinTerminal && @@ -287,11 +285,12 @@ -- in place for now, for users who haven't upgraded yet. (isTerm || (isNothing bamboo && isNothing jenkins)) hostBinDirPath <- parseAbsDir hostBinDir - newPathEnv <- augmentPath + newPathEnv <- either throwM return $ augmentPath + ( toFilePath <$> [ hostBinDirPath - , sandboxHomeDir $(mkRelDir ".local/bin")] + , sandboxHomeDir $(mkRelDir ".local/bin")]) (T.pack <$> lookupImageEnv "PATH" imageEnvVars) - (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker + (cmnd,args,envVars,extraMount) <- getCmdArgs docker imageInfo isRemoteDocker pwd <- getCurrentDir liftIO (do updateDockerImageLastUsed config iiId (toFilePath projectRoot) @@ -309,9 +308,7 @@ (Files.createSymbolicLink (toFilePathNoTrailingSep sshDir) (toFilePathNoTrailingSep (sandboxHomeDir sshRelDir)))) - containerID <- (trim . decodeUtf8) <$> readDockerProcess - envOverride - (Just projectRoot) + containerID <- withWorkingDir (toFilePath projectRoot) $ trim . decodeUtf8 <$> readDockerProcess (concat [["create" ,"--net=host" @@ -356,30 +353,23 @@ run <- askRunInIO oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do let sigHandler = run $ do - readProcessNull Nothing envOverride "docker" - ["kill","--signal=" ++ show sig,containerID] + readProcessNull "docker" ["kill","--signal=" ++ show sig,containerID] when (sig `elem` [sigTERM,sigABRT]) $ do -- Give the container 30 seconds to exit gracefully, then send a sigKILL to force it - liftIO $ threadDelay 30000000 - readProcessNull Nothing envOverride "docker" ["kill",containerID] + threadDelay 30000000 + readProcessNull "docker" ["kill",containerID] oldHandler <- liftIO $ installHandler sig (Catch sigHandler) Nothing return (sig, oldHandler) #endif - let cmd = Cmd Nothing - "docker" - envOverride - (concat [["start"] - ,["-a" | not (dockerDetach docker)] - ,["-i" | keepStdinOpen] - ,[containerID]]) - e <- finally - (try $ callProcess' - (\cp -> cp { delegate_ctlc = False }) - cmd) + let args' = concat [["start"] + ,["-a" | not (dockerDetach docker)] + ,["-i" | keepStdinOpen] + ,[containerID]] + e <- try (proc "docker" args' $ runProcess_ . setDelegateCtlc False) + `finally` (do unless (dockerPersist docker || dockerDetach docker) $ - catch - (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID]) - (\(_::ReadProcessException) -> return ()) + readProcessNull "docker" ["rm","-f",containerID] + `catch` (\(_::ExitCodeException) -> return ()) #ifndef WINDOWS forM_ oldHandlers $ \(sig,oldHandler) -> liftIO $ installHandler sig oldHandler Nothing @@ -404,26 +394,23 @@ -- | Clean-up old docker images and containers. cleanup :: HasConfig env => CleanupOpts -> RIO env () -cleanup opts = - do config <- view configL +cleanup opts = do + config <- view configL let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker - let runDocker = readDockerProcess envOverride Nothing - imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"] - danglingImagesOut <- runDocker ["images","--no-trunc","-f","dangling=true"] - runningContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=running"] - restartingContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=restarting"] - exitedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=exited"] - pausedContainersOut <- runDocker ["ps","-a","--no-trunc","-f","status=paused"] + checkDockerVersion docker + imagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=false"] + danglingImagesOut <- readDockerProcess ["images","--no-trunc","-f","dangling=true"] + runningContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=running"] + restartingContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=restarting"] + exitedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=exited"] + pausedContainersOut <- readDockerProcess ["ps","-a","--no-trunc","-f","status=paused"] let imageRepos = parseImagesOut imagesOut danglingImageHashes = Map.keys (parseImagesOut danglingImagesOut) runningContainers = parseContainersOut runningContainersOut ++ parseContainersOut restartingContainersOut stoppedContainers = parseContainersOut exitedContainersOut ++ parseContainersOut pausedContainersOut - inspectMap <- inspects envOverride - (Map.keys imageRepos ++ + inspectMap <- inspects (Map.keys imageRepos ++ danglingImageHashes ++ map fst stoppedContainers ++ map fst runningContainers) @@ -448,31 +435,40 @@ CleanupImmediate -> return plan CleanupDryRun -> do liftIO (LBS.hPut stdout plan) return LBS.empty - mapM_ (performPlanLine envOverride) + mapM_ performPlanLine (reverse (filter filterPlanLine (lines (LBS.unpack plan')))) - allImageHashesOut <- runDocker ["images","-aq","--no-trunc"] + allImageHashesOut <- readDockerProcess ["images","-aq","--no-trunc"] liftIO (pruneDockerImagesLastUsed config (lines (decodeUtf8 allImageHashesOut))) where filterPlanLine line = case line of c:_ | isSpace c -> False _ -> True - performPlanLine envOverride line = + performPlanLine line = case filter (not . null) (words (takeWhile (/= '#') line)) of [] -> return () (c:_):t:v:_ -> do args <- if | toUpper c == 'R' && t == imageStr -> - do logInfo (concatT ["Removing image: '",v,"'"]) + do logInfo $ + "Removing image: '" <> + fromString v <> + "'" return ["rmi",v] | toUpper c == 'R' && t == containerStr -> - do logInfo (concatT ["Removing container: '",v,"'"]) + do logInfo $ + "Removing container: '" <> + fromString v <> + "'" return ["rm","-f",v] | otherwise -> throwM (InvalidCleanupCommandException line) - e <- try (readDockerProcess envOverride Nothing args) + e <- try (readDockerProcess args) case e of - Left ex@ProcessFailed{} -> - logError (concatT ["Could not remove: '",v,"': ", show ex]) - Left e' -> throwM e' + Left ex -> + logError $ + "Could not remove: '" <> + fromString v <> + "': " <> + displayShow (ex :: ExitCodeException) Right _ -> return () _ -> throwM (InvalidCleanupCommandException line) parseImagesOut = Map.fromListWith (++) . map parseImageRepo . drop 1 . lines . decodeUtf8 @@ -629,30 +625,29 @@ containerStr = "container" -- | Inspect Docker image or container. -inspect :: (MonadUnliftIO m,MonadLogger m) - => EnvOverride -> String -> m (Maybe Inspect) -inspect envOverride image = - do results <- inspects envOverride [image] +inspect :: (HasProcessContext env, HasLogFunc env) + => String -> RIO env (Maybe Inspect) +inspect image = + do results <- inspects [image] case Map.toList results of [] -> return Nothing [(_,i)] -> return (Just i) _ -> throwIO (InvalidInspectOutputException "expect a single result") -- | Inspect multiple Docker images and/or containers. -inspects :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> [String] -> m (Map String Inspect) -inspects _ [] = return Map.empty -inspects envOverride images = - do maybeInspectOut <- - try (readDockerProcess envOverride Nothing ("inspect" : images)) +inspects :: (HasProcessContext env, HasLogFunc env) + => [String] -> RIO env (Map String Inspect) +inspects [] = return Map.empty +inspects images = + do maybeInspectOut <- try (readDockerProcess ("inspect" : images)) case maybeInspectOut of 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 -> throwIO (InvalidInspectOutputException msg) Right results -> return (Map.fromList (map (\r -> (iiId r,r)) results)) - Left (ProcessFailed _ _ _ err) - | any (`LBS.isPrefixOf` err) missingImagePrefixes -> return Map.empty + Left ece + | any (`LBS.isPrefixOf` eceStderr ece) missingImagePrefixes -> return Map.empty Left e -> throwIO e where missingImagePrefixes = ["Error: No such image", "Error: No such object:"] @@ -661,50 +656,45 @@ pull = do config <- view configL let docker = configDocker config - envOverride <- getEnvOverride (configPlatform config) - checkDockerVersion envOverride docker - pullImage envOverride docker (dockerImage docker) + checkDockerVersion docker + pullImage docker (dockerImage docker) -- | Pull Docker image from registry. -pullImage :: (MonadLogger m,MonadIO m,MonadThrow m) - => EnvOverride -> DockerOpts -> String -> m () -pullImage envOverride docker image = - do logInfo (concatT ["Pulling image from registry: '",image,"'"]) +pullImage :: (HasProcessContext env, HasLogFunc env) + => DockerOpts -> String -> RIO env () +pullImage docker image = + do logInfo ("Pulling image from registry: '" <> fromString image <> "'") when (dockerRegistryLogin docker) (do logInfo "You may need to log in." - callProcess $ Cmd - Nothing + proc "docker" - envOverride (concat [["login"] ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) - ,[takeWhile (/= '/') image]])) + ,[takeWhile (/= '/') image]]) + runProcess_) -- We redirect the stdout of the process to stderr so that the output -- of @docker pull@ will not interfere with the output of other -- commands when using --auto-docker-pull. See issue #2733. - let stdoutToStderr cp = cp - { std_out = UseHandle stderr - , std_err = UseHandle stderr - , std_in = CreatePipe - } - (Just hin, _, _, ph) <- createProcess' "pullImage" stdoutToStderr $ - Cmd Nothing "docker" envOverride ["pull",image] - liftIO (hClose hin) - ec <- liftIO (waitForProcess ph) + ec <- proc "docker" ["pull", image] $ \pc0 -> do + let pc = setStdout (useHandleOpen stderr) + $ setStderr (useHandleOpen stderr) + $ setStdin closed + pc0 + runProcess pc case ec of ExitSuccess -> return () ExitFailure _ -> throwIO (PullFailedException image) -- | Check docker version (throws exception if incorrect) checkDockerVersion - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> DockerOpts -> m () -checkDockerVersion envOverride docker = - do dockerExists <- doesExecutableExist envOverride "docker" + :: (HasProcessContext env, HasLogFunc env) + => DockerOpts -> RIO env () +checkDockerVersion docker = + do dockerExists <- doesExecutableExist "docker" unless dockerExists (throwIO DockerNotInstalledException) - dockerVersionOut <- readDockerProcess envOverride Nothing ["--version"] + dockerVersionOut <- readDockerProcess ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> case parseVersionFromString (stripVersion v) of @@ -736,13 +726,13 @@ -- | 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 :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) - => Config -> DockerEntrypoint -> m () +entrypoint :: (HasProcessContext env, HasLogFunc env) + => Config -> DockerEntrypoint -> RIO env () entrypoint config@Config{..} DockerEntrypoint{..} = modifyMVar_ entrypointMVar $ \alreadyRan -> do -- Only run the entrypoint once unless alreadyRan $ do - envOverride <- getEnvOverride configPlatform + envOverride <- view processContextL homeDir <- liftIO $ parseAbsDir =<< getEnv "HOME" -- Get the UserEntry for the 'stack' user in the image, if it exists estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ @@ -751,7 +741,7 @@ case deUser of Nothing -> return () Just (DockerUser 0 _ _ _) -> return () - Just du -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir du + Just du -> withProcessContext envOverride $ updateOrCreateStackUser estackUserEntry0 homeDir du case estackUserEntry0 of Left _ -> return () Right ue -> do @@ -763,13 +753,13 @@ when buildPlanDirExists $ do (_, buildPlans) <- listDir (buildPlanDir origStackRoot) forM_ buildPlans $ \srcBuildPlan -> do - let destBuildPlan = buildPlanDir configStackRoot filename srcBuildPlan + let destBuildPlan = buildPlanDir (view stackRootL config) filename srcBuildPlan exists <- doesFileExist destBuildPlan unless exists $ do ensureDir (parent destBuildPlan) copyFile srcBuildPlan destBuildPlan - forM_ configPackageIndices $ \pkgIdx -> do - msrcIndex <- flip runReaderT (config{configStackRoot = origStackRoot}) $ do + forM_ clIndices $ \pkgIdx -> do + msrcIndex <- runRIO (set stackRootL origStackRoot config) $ do srcIndex <- configPackageIndex (indexName pkgIdx) exists <- doesFileExist srcIndex return $ if exists @@ -777,8 +767,8 @@ else Nothing case msrcIndex of Nothing -> return () - Just srcIndex -> do - flip runReaderT config $ do + Just srcIndex -> + runRIO config $ do destIndex <- configPackageIndex (indexName pkgIdx) exists <- doesFileExist destIndex unless exists $ do @@ -786,15 +776,16 @@ copyFile srcIndex destIndex return True where - updateOrCreateStackUser envOverride estackUserEntry homeDir DockerUser{..} = do + CabalLoader {..} = configCabalLoader + updateOrCreateStackUser estackUserEntry homeDir DockerUser{..} = do case estackUserEntry of Left _ -> do -- If no 'stack' user in image, create one with correct UID/GID and home directory - readProcessNull Nothing envOverride "groupadd" + readProcessNull "groupadd" ["-o" ,"--gid",show duGid ,stackUserName] - readProcessNull Nothing envOverride "useradd" + readProcessNull "useradd" ["-oN" ,"--uid",show duUid ,"--gid",show duGid @@ -802,17 +793,17 @@ ,stackUserName] Right _ -> do -- If there is already a 'stack' user in the image, adjust its UID/GID and home directory - readProcessNull Nothing envOverride "usermod" + readProcessNull "usermod" ["-o" ,"--uid",show duUid ,"--home",toFilePathNoTrailingSep homeDir ,stackUserName] - readProcessNull Nothing envOverride "groupmod" + readProcessNull "groupmod" ["-o" ,"--gid",show duGid ,stackUserName] forM_ duGroups $ \gid -> do - readProcessNull Nothing envOverride "groupadd" + readProcessNull "groupadd" ["-o" ,"--gid",show gid ,"group" ++ show gid] @@ -854,9 +845,9 @@ -- process. Throws a 'ReadProcessException' exception if the -- process fails. Logs process's stderr using @logError@. readDockerProcess - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> Maybe (Path Abs Dir) -> [String] -> m BS.ByteString -readDockerProcess envOverride mpwd = readProcessStdout mpwd envOverride "docker" + :: (HasProcessContext env, HasLogFunc env) + => [String] -> RIO env BS.ByteString +readDockerProcess args = BL.toStrict <$> proc "docker" args readProcessStdout_ -- FIXME stderr isn't logged with logError, should it be? -- | Name of home directory within docker sandbox. homeDirName :: Path Rel Dir @@ -870,10 +861,6 @@ decodeUtf8 :: BS.ByteString -> String decodeUtf8 bs = T.unpack (T.decodeUtf8 bs) --- | Convenience function constructing message for @log*@. -concatT :: [String] -> Text -concatT = T.pack . concat - -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir fromMaybeProjectRoot = fromMaybe (impureThrow CannotDetermineProjectRootException) @@ -933,7 +920,6 @@ -- | Function to get command and arguments to run in Docker container type GetCmdArgs env = DockerOpts - -> EnvOverride -> Inspect -> Bool -> RIO env (FilePath,[String],[(String,String)],[Mount]) diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs --- a/src/Stack/Docker/GlobalDB.hs +++ b/src/Stack/Docker/GlobalDB.hs @@ -16,7 +16,8 @@ ,DockerImageExeId) where -import Control.Monad.Logger (NoLoggingT) +import Control.Monad.Logger (NoLoggingT) -- TODO remove dep when persistent drops monad-logger +import Control.Monad.Trans.Resource (ResourceT) import Stack.Prelude import Data.List (sortBy, isInfixOf, stripPrefix) import Data.List.Extra (stripSuffix) @@ -58,10 +59,13 @@ -- | Get a list of Docker image hashes and when they were last used. getDockerImagesLastUsed :: Config -> IO [DockerImageLastUsed] getDockerImagesLastUsed config = - do imageProjects <- withGlobalDB config (selectList [] [Asc DockerImageProjectLastUsedTime]) - return (sortBy (flip sortImage) - (Map.toDescList (Map.fromListWith (++) - (map mapImageProject imageProjects)))) + sortBy (flip sortImage) + . Map.toDescList + . Map.fromListWith (++) + . map mapImageProject + <$> withGlobalDB + config + (selectList [] [Asc DockerImageProjectLastUsedTime]) where mapImageProject (Entity _ imageProject) = (dockerImageProjectImageHash imageProject @@ -84,9 +88,9 @@ -- | Get the record of whether an executable is compatible with a Docker image getDockerImageExe :: Config -> String -> FilePath -> UTCTime -> IO (Maybe Bool) getDockerImageExe config imageId exePath exeTimestamp = - withGlobalDB config $ do - mentity <- getBy (DockerImageExeUnique imageId exePath exeTimestamp) - return (fmap (dockerImageExeCompatible . entityVal) mentity) + withGlobalDB config $ + fmap (dockerImageExeCompatible . entityVal) <$> + getBy (DockerImageExeUnique imageId exePath exeTimestamp) -- | Seet the record of whether an executable is compatible with a Docker image setDockerImageExe :: Config -> String -> FilePath -> UTCTime -> Bool -> IO () diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -23,8 +23,9 @@ import qualified Data.Text.IO as Text import qualified Data.Traversable as T import Distribution.Text (display) -import Distribution.License (License(BSD3)) -import Stack.Build (withLoadPackage) +import qualified Distribution.SPDX.License as SPDX +import Distribution.License (License(BSD3), licenseFromSPDX) +import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source import Stack.Build.Target @@ -32,7 +33,7 @@ import Stack.Constants import Stack.Package import Stack.PackageDump (DumpPackage(..)) -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Stack.Types.Build import Stack.Types.BuildPlan import Stack.Types.Config @@ -82,7 +83,7 @@ data DotPayload = DotPayload { payloadVersion :: Maybe Version -- ^ The package version. - , payloadLicense :: Maybe License + , payloadLicense :: Maybe (Either SPDX.License License) -- ^ The license the package was released under. } deriving (Eq, Show) @@ -116,23 +117,20 @@ , boptsCLIFlags = dotFlags dotOpts } let graph = Map.fromList (localDependencies dotOpts (filter lpWanted locals)) - menv <- getMinimalEnvOverride - (installedMap, globalDump, _, _) <- getInstalled menv - (GetInstalledOpts False False False) + (installedMap, globalDump, _, _) <- getInstalled (GetInstalledOpts False False False) sourceMap -- TODO: Can there be multiple entries for wired-in-packages? If so, -- this will choose one arbitrarily.. let globalDumpMap = Map.fromList $ map (\dp -> (packageIdentifierName (dpPackageIdent dp), dp)) globalDump globalIdMap = Map.fromList $ map (\dp -> (dpGhcPkgId dp, dpPackageIdent dp)) globalDump - withLoadPackage (\loader -> do - let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps - 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 loc flags ghcOptions) - liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) + let depLoader = createDepLoader sourceMap installedMap globalDumpMap globalIdMap loadPackageDeps + 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 $ Right BSD3)) + | otherwise = fmap (packageAllDeps &&& makePayload) (loadPackage loc flags ghcOptions) + resolveDependencies (dotDependencyDepth dotOpts) graph depLoader where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) listDependencies :: HasEnvConfig env @@ -145,7 +143,7 @@ where go name payload = let payloadText = if listDepsLicense opts - then maybe "" (Text.pack . display) (payloadLicense payload) + then maybe "" (Text.pack . display . either licenseFromSPDX id) (payloadLicense payload) else maybe "" (Text.pack . show) (payloadVersion payload) line = packageNameText name <> listDepsSep opts <> payloadText in liftIO $ Text.putStrLn line @@ -236,7 +234,7 @@ case maybePkg of Just (_, Library _ _ mlicense) -> mlicense _ -> Nothing - payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (dpLicense dp) + payloadFromDump dp = DotPayload (Just $ packageIdentifierVersion $ dpPackageIdent dp) (Right <$> dpLicense dp) -- | Resolve the direct (depth 0) external dependencies of the given local packages localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName, (Set PackageName, DotPayload))] @@ -263,8 +261,8 @@ printLeaves graph void (Map.traverseWithKey printEdges (fst <$> graph)) liftIO $ Text.putStrLn "}" - where filteredLocals = Set.filter (\local -> - packageNameString local `Set.notMember` dotPrune dotOpts) locals + where filteredLocals = Set.filter (\local' -> + packageNameString local' `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options printLocalNodes :: (F.Foldable t, MonadIO m) diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs deleted file mode 100644 --- a/src/Stack/Exec.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - --- | Execute commands within the properly configured Stack --- environment. - -module Stack.Exec where - -import Stack.Prelude -import Stack.Types.Config -import System.Process.Log - -import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) -import System.Exit -import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) -#ifdef WINDOWS -import System.Process.Read (EnvOverride) -#else -import qualified System.Process.PID1 as PID1 -import System.Process.Read (EnvOverride, envHelper, preProcess) -#endif - --- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH. --- --- Note that this also passes through the GHCRTS environment variable. --- See https://github.com/commercialhaskell/stack/issues/3444 -defaultEnvSettings :: EnvSettings -defaultEnvSettings = EnvSettings - { esIncludeLocals = True - , esIncludeGhcPackagePath = True - , esStackExe = True - , esLocaleUtf8 = False - , esKeepGhcRts = True - } - --- | Environment settings which do not embellish the environment --- --- Note that this also passes through the GHCRTS environment variable. --- See https://github.com/commercialhaskell/stack/issues/3444 -plainEnvSettings :: EnvSettings -plainEnvSettings = EnvSettings - { esIncludeLocals = False - , esIncludeGhcPackagePath = False - , esStackExe = False - , esLocaleUtf8 = False - , esKeepGhcRts = True - } - --- | Execute a process within the Stack configured environment. --- --- Execution will not return, because either: --- --- 1) On non-windows, execution is taken over by execv of the --- sub-process. This allows signals to be propagated (#527) --- --- 2) On windows, an 'ExitCode' exception will be thrown. -exec :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m b -#ifdef WINDOWS -exec = execSpawn -#else -exec menv cmd0 args = do - cmd <- preProcess Nothing menv cmd0 - withProcessTimeLog cmd args $ - liftIO $ PID1.run cmd args (envHelper menv) -#endif - --- | Like 'exec', but does not use 'execv' on non-windows. This way, there --- is a sub-process, which is helpful in some cases (#1306) --- --- This function only exits by throwing 'ExitCode'. -execSpawn :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m b -execSpawn menv cmd0 args = do - e <- withProcessTimeLog cmd0 args $ - try (callProcess (Cmd Nothing cmd0 menv args)) - liftIO $ case e of - Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec - Right () -> exitSuccess - -execObserve :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> String -> [String] -> m String -execObserve menv cmd0 args = do - e <- withProcessTimeLog cmd0 args $ - try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) - case e of - Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec - Right s -> return s diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} -- | Functionality for downloading packages securely for cabal's usage. @@ -26,7 +27,7 @@ , resolvePackagesAllowMissing , ResolvedPackage (..) , withCabalFiles - , withCabalLoader + , loadFromIndex ) where import qualified Codec.Archive.Tar as Tar @@ -36,7 +37,6 @@ import Stack.Prelude import Crypto.Hash (SHA256 (..)) import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet @@ -48,17 +48,16 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Text.Metrics +import Lens.Micro (to) import Network.HTTP.Download import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Stack.PackageIndex import Stack.Types.BuildPlan -import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName -import Stack.Types.Runner import Stack.Types.Version import qualified System.FilePath as FP import System.IO (SeekMode (AbsoluteSeek)) @@ -104,7 +103,7 @@ (if uses00Index then "\n\nYou seem to be using a legacy 00-index.tar.gz tarball.\nConsider changing your configuration to use a 01-index.tar.gz file.\nAlternatively, you can set the ignore-revision-mismatch setting to true.\nFor more information, see: https://github.com/commercialhaskell/stack/issues/3520" else "") -- | Fetch packages into the cache without unpacking -fetchPackages :: HasConfig env => Set PackageIdentifier -> RIO env () +fetchPackages :: HasCabalLoader env => Set PackageIdentifier -> RIO env () fetchPackages idents' = do resolved <- resolvePackages Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved @@ -117,7 +116,7 @@ idents = map (flip PackageIdentifierRevision CFILatest) $ Set.toList idents' -- | Intended to work for the command line command. -unpackPackages :: HasConfig env +unpackPackages :: HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers @@ -132,12 +131,11 @@ unless (Map.null alreadyUnpacked) $ throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked unpacked <- fetchPackages' Nothing toFetch - F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $ T.pack $ concat - [ "Unpacked " - , packageIdentifierString ident - , " to " - , toFilePath dest'' - ] + F.forM_ (Map.toList unpacked) $ \(ident, dest'') -> logInfo $ + "Unpacked " <> + fromString (packageIdentifierString ident) <> + " to " <> + fromString (toFilePath dest'') where -- Possible future enhancement: parse names as name + version range parse s = @@ -152,7 +150,7 @@ -- | Same as 'unpackPackageIdents', but for a single package. unpackPackageIdent - :: HasConfig env + :: HasCabalLoader env => Path Abs Dir -- ^ unpack directory -> Path Rel Dir -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> PackageIdentifierRevision @@ -170,7 +168,7 @@ -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents - :: HasConfig env + :: HasCabalLoader env => Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> [PackageIdentifierRevision] @@ -190,7 +188,7 @@ deriving Show -- | Resolve a set of package names and identifiers into @FetchPackage@ values. -resolvePackages :: HasConfig env +resolvePackages :: HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> [PackageIdentifierRevision] -> Set PackageName @@ -211,9 +209,9 @@ -- | Does the configuration use a 00-index.tar.gz file for indices? -- See -getUses00Index :: HasConfig env => RIO env Bool +getUses00Index :: HasCabalLoader env => RIO env Bool getUses00Index = - any is00 <$> view packageIndicesL + any is00 <$> view (cabalLoaderL.to clIndices) where is00 :: PackageIndex -> Bool is00 index = "00-index.tar.gz" `T.isInfixOf` indexLocation index @@ -226,7 +224,7 @@ -- a warning, that's no longer necessary or desirable since all info -- should be present and checked). resolvePackagesAllowMissing - :: forall env. HasConfig env + :: forall env. HasCabalLoader env => Maybe SnapshotDef -- ^ when looking up by name, take from this build plan -> [PackageIdentifierRevision] -> Set PackageName @@ -266,15 +264,19 @@ (missingNames, idents1) = partitionEithers $ map (\name -> maybe (Left name) Right (getNamed name)) (Set.toList names0) - config <- view configL + cl <- view cabalLoaderL let (missingIdents, resolved) = partitionEithers - $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage config pir cache)) + $ map (\pir -> maybe (Left pir) Right (lookupResolvedPackage cl pir cache)) $ idents0 <> idents1 return (Set.fromList missingNames, HashSet.fromList missingIdents, resolved) -lookupResolvedPackage :: Config -> PackageIdentifierRevision -> PackageCache PackageIndex -> Maybe ResolvedPackage -lookupResolvedPackage config (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do +lookupResolvedPackage + :: CabalLoader + -> PackageIdentifierRevision + -> PackageCache PackageIndex + -> Maybe ResolvedPackage +lookupResolvedPackage cl (PackageIdentifierRevision ident@(PackageIdentifier name version) cfi) (PackageCache cache) = do (index, mdownload, files) <- HashMap.lookup name cache >>= HashMap.lookup version let moffsetSize = case cfi of @@ -288,7 +290,7 @@ case moffsetSize of Just x -> Just x Nothing - | configIgnoreRevisionMismatch config -> Just $ snd $ NE.last files + | clIgnoreRevisionMismatch cl -> Just $ snd $ NE.last files | otherwise -> Nothing Just ResolvedPackage { rpIdent = ident @@ -314,11 +316,11 @@ -- | Add the cabal files to a list of idents with their caches. withCabalFiles - :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + :: HasCabalLoader env => IndexName -> [(ResolvedPackage, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) - -> m [b] + -> RIO env [b] withCabalFiles name pkgs f = do indexPath <- configPackageIndex name withBinaryFile (toFilePath indexPath) ReadMode @@ -331,71 +333,51 @@ cabalBS <- S.hGet h $ fromIntegral size f ident tf cabalBS --- | Provide a function which will load up a cabal @ByteString@ from the --- package indices. -withCabalLoader - :: HasConfig env - => ((PackageIdentifierRevision -> IO ByteString) -> RIO env a) - -> RIO env a -withCabalLoader inner = do - -- 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 - -- - -- TODO: probably makes sense to move this concern into getPackageCaches - updateRef <- newMVar True - - u <- askUnliftIO - - -- TODO in the future, keep all of the necessary @Handle@s open - let doLookup :: PackageIdentifierRevision - -> IO ByteString - doLookup ident = do - bothCaches <- unliftIO u getPackageCaches - eres <- unliftIO u $ lookupPackageIdentifierExact ident bothCaches - case eres of - Just bs -> return bs - -- Update the cache and try again - Nothing -> do - let fuzzy = fuzzyLookupCandidates ident bothCaches - suggestions = case fuzzy of - FRNameNotFound Nothing -> "" - FRNameNotFound (Just cs) -> - "Perhaps you meant " <> orSeparated cs <> "?" - FRVersionNotFound cs -> "Possible candidates: " <> - commaSeparated (NE.map packageIdentifierText cs) - <> "." - FRRevisionNotFound cs -> - "The specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) - <> "." - join $ modifyMVar updateRef $ \toUpdate -> - if toUpdate then do - unliftIO u $ do - logInfo $ T.concat - [ "Didn't see " - , T.pack $ packageIdentifierRevisionString ident - , " in your package indices.\n" - , "Updating and trying again." - ] - updateAllIndices - _ <- getPackageCaches - return () - return (False, doLookup ident) - else do - uses00Index <- unliftIO u getUses00Index - return (toUpdate, throwIO $ UnknownPackageIdentifiers - (HashSet.singleton ident) (T.unpack suggestions) uses00Index) - inner doLookup +loadFromIndex :: HasCabalLoader env => PackageIdentifierRevision -> RIO env ByteString +loadFromIndex ident = do + -- TODO in the future, keep all of the necessary @Handle@s open + bothCaches <- getPackageCaches + mres <- lookupPackageIdentifierExact ident bothCaches + case mres of + Just bs -> return bs + -- Update the cache and try again + Nothing -> do + let fuzzy = fuzzyLookupCandidates ident bothCaches + suggestions = case fuzzy of + FRNameNotFound Nothing -> "" + FRNameNotFound (Just cs) -> + "Perhaps you meant " <> orSeparated cs <> "?" + FRVersionNotFound cs -> "Possible candidates: " <> + commaSeparated (NE.map packageIdentifierText cs) + <> "." + FRRevisionNotFound cs -> + "The specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map (T.pack . packageIdentifierRevisionString) cs) + <> "." + cl <- view cabalLoaderL + join $ modifyMVar (clUpdateRef cl) $ \toUpdate -> + if toUpdate then do + logInfo $ + "Didn't see " <> + fromString (packageIdentifierRevisionString ident) <> + " in your package indices.\n" <> + "Updating and trying again." + updateAllIndices + _ <- getPackageCaches + return (False, loadFromIndex ident) + else do + uses00Index <- getUses00Index + return (toUpdate, throwIO $ UnknownPackageIdentifiers + (HashSet.singleton ident) (T.unpack suggestions) uses00Index) lookupPackageIdentifierExact - :: (MonadReader env m, MonadUnliftIO m, HasConfig env, MonadThrow m) + :: HasCabalLoader env => PackageIdentifierRevision -> PackageCache PackageIndex - -> m (Maybe ByteString) + -> RIO env (Maybe ByteString) lookupPackageIdentifierExact identRev cache = do - config <- view configL - forM (lookupResolvedPackage config identRev cache) $ \rp -> do + cl <- view cabalLoaderL + forM (lookupResolvedPackage cl identRev cache) $ \rp -> do [bs] <- withCabalFiles (indexName (rpIndex rp)) [(rp, ())] $ \_ _ bs -> return bs return bs @@ -450,7 +432,7 @@ $ cache -- | Figure out where to fetch from. -getToFetch :: HasConfig env +getToFetch :: HasCabalLoader env => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> [ResolvedPackage] -> RIO env ToFetchResult @@ -509,28 +491,25 @@ -- @ -- -- Since 0.1.0.0 -fetchPackages' :: HasConfig env +fetchPackages' :: forall env. HasCabalLoader env => Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 -> Map PackageIdentifier ToFetch -> RIO env (Map PackageIdentifier (Path Abs Dir)) fetchPackages' mdistDir toFetchAll = do - connCount <- view $ configL.to configConnectionCount - outputVar <- liftIO $ newTVarIO Map.empty + connCount <- view $ cabalLoaderL.to clConnectionCount + outputVar <- newTVarIO Map.empty - run <- askRunInIO parMapM_ connCount - (go outputVar run) + (go outputVar) (Map.toList toFetchAll) - liftIO $ readTVarIO outputVar + readTVarIO outputVar where - go :: (MonadUnliftIO m,MonadThrow m,MonadLogger m,HasRunner env, MonadReader env m) - => TVar (Map PackageIdentifier (Path Abs Dir)) - -> (m () -> IO ()) + go :: TVar (Map PackageIdentifier (Path Abs Dir)) -> (PackageIdentifier, ToFetch) - -> m () - go outputVar run (ident, toFetch) = do + -> RIO env () + go outputVar (ident, toFetch) = do req <- parseUrlThrow $ T.unpack $ tfUrl toFetch let destpath = tfTarball toFetch @@ -542,7 +521,7 @@ , drRetryPolicy = drRetryPolicyDefault } let progressSink _ = - liftIO $ run $ logInfo $ packageIdentifierText ident <> ": download" + logInfo $ display ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink identStrP <- parseRelDir $ packageIdentifierString ident @@ -579,7 +558,7 @@ atomically $ modifyTVar outputVar $ Map.insert ident destDir F.forM_ unexpectedEntries $ \(path, entryType) -> - logWarn $ "Unexpected entry type " <> entryType <> " for entry " <> T.pack path + logWarn $ "Unexpected entry type " <> display entryType <> " for entry " <> fromString path -- | Internal function used to unpack tarball. -- @@ -589,16 +568,13 @@ untar :: forall b1 b2. Path b1 File -> Path Rel Dir -> Path b2 Dir -> IO [(FilePath, T.Text)] untar tarPath expectedTarFolder destDirParent = do ensureDir destDirParent - withBinaryFile (toFilePath tarPath) ReadMode $ \h -> do - -- Avoid using L.readFile, which is more likely to leak - -- resources - lbs <- L.hGetContents h + withLazyFile (toFilePath tarPath) $ \lbs -> do let rawEntries = fmap (either wrap wrap) $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder) $ Tar.read $ decompress lbs filterEntries - :: Monoid w => (Tar.Entry -> (Bool, w)) + :: (Semigroup w, Monoid w) => (Tar.Entry -> (Bool, w)) -> Tar.Entries b -> (Tar.Entries b, w) -- Allow collecting warnings, Writer-monad style. filterEntries f = @@ -670,3 +646,12 @@ commaSeparated :: NonEmpty T.Text -> T.Text commaSeparated = F.fold . NE.intersperse ", " + +-- | Location of a package tarball +configPackageTarball :: HasCabalLoader env => IndexName -> PackageIdentifier -> RIO env (Path Abs File) +configPackageTarball iname ident = do + root <- configPackageIndexRoot iname + name <- parseRelDir $ packageNameString $ packageIdentifierName ident + ver <- parseRelDir $ versionString $ packageIdentifierVersion ident + base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" + return (root $(mkRelDir "packages") name ver base) diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -4,26 +4,16 @@ module Stack.FileWatch ( fileWatch , fileWatchPoll - , printExceptionStderr ) where -import Blaze.ByteString.Builder (toLazyByteString, copyByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Concurrent.STM (check) import Stack.Prelude -import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map import qualified Data.Set as Set import GHC.IO.Exception import Path -import System.Console.ANSI import System.FSNotify -import System.IO (stdout, stderr, hPutStrLn, getLine) - --- | Print an exception to stderr -printExceptionStderr :: Exception e => e -> IO () -printExceptionStderr e = - L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n" +import System.IO (hPutStrLn, getLine) fileWatch :: Handle -> ((Set (Path Abs File) -> IO ()) -> IO ()) @@ -45,14 +35,11 @@ -> IO () fileWatchConf cfg out inner = withManagerConf cfg $ \manager -> do let putLn = hPutStrLn out - let withColor color action = do - outputIsTerminal <- hIsTerminalDevice stdout + outputIsTerminal <- hIsTerminalDevice out + let withColor color str = putLn $ do if outputIsTerminal - then do - setSGR [SetColor Foreground Dull color] - action - setSGR [Reset] - else action + then concat [color, str, reset] + else str allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True @@ -139,10 +126,14 @@ case eres of Left e -> do let color = case fromException e of - Just ExitSuccess -> Green - _ -> Red - withColor color $ printExceptionStderr e - _ -> withColor Green $ - putLn "Success! Waiting for next file change." + Just ExitSuccess -> green + _ -> red + withColor color $ show e + _ -> withColor green "Success! Waiting for next file change." putLn "Type help for available commands. Press enter to force a rebuild." + +green, red, reset :: String +green = "\ESC[32m" +red = "\ESC[31m" +reset = "\ESC[0m" diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -23,6 +23,7 @@ import Stack.Prelude import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -37,16 +38,16 @@ import Stack.Types.PackageName import Stack.Types.Version import System.FilePath (searchPathSeparator) -import System.Process.Read +import RIO.Process -- | Get the global package database -getGlobalDB :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> m (Path Abs Dir) -getGlobalDB menv wc = do +getGlobalDB :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> RIO env (Path Abs Dir) +getGlobalDB 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 throwIO return + bs <- ghcPkg wc [] ["list", "--global"] >>= either throwIO return let fp = S8.unpack $ stripTrailingColon $ firstLine bs liftIO $ resolveDir' fp where @@ -57,27 +58,29 @@ firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n') -- | Run the ghc-pkg executable -ghcPkg :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +ghcPkg :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> [Path Abs Dir] -> [String] - -> m (Either ReadProcessException S8.ByteString) -ghcPkg menv wc pkgDbs args = do + -> RIO env (Either SomeException S8.ByteString) +ghcPkg wc pkgDbs args = do eres <- go case eres of - Left _ -> do - mapM_ (createDatabase menv wc) pkgDbs - go - Right _ -> return eres + Left _ -> do + mapM_ (createDatabase wc) pkgDbs + go + Right _ -> return eres where - go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args' + go = fmap (fmap BL.toStrict) + $ tryAny + $ proc (ghcPkgExeName wc) args' readProcessStdout_ args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. -createDatabase :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () -createDatabase menv wc db = do +createDatabase + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> Path Abs Dir -> RIO env () +createDatabase wc db = do exists <- doesFileExist (db $(mkRelFile "package.cache")) unless exists $ do -- ghc-pkg requires that the database directory does not exist @@ -86,11 +89,10 @@ dirExists <- doesDirExist db args <- if dirExists then do - logWarn $ T.pack $ concat - [ "The package database located at " - , toFilePath db - , " is corrupted (missing its package.cache file)." - ] + logWarn $ + "The package database located at " <> + fromString (toFilePath db) <> + " is corrupted (missing its package.cache file)." logWarn "Proceeding with a recache" return ["--package-db", toFilePath db, "recache"] else do @@ -99,12 +101,9 @@ -- finding out it isn't the hard way ensureDir (parent db) return ["init", toFilePath db] - eres <- tryProcessStdout Nothing menv (ghcPkgExeName wc) args - case eres of - Left e -> do - logError $ T.pack $ "Unable to create package database at " ++ toFilePath db - throwIO e - Right _ -> return () + void $ proc (ghcPkgExeName wc) args $ \pc -> + readProcessStdout_ pc `onException` + logError ("Unable to create package database at " <> fromString (toFilePath db)) -- | Get the name to use for "ghc-pkg", given the compiler version. ghcPkgExeName :: WhichCompiler -> String @@ -124,51 +123,47 @@ -- | Get the value of a field of the package. findGhcPkgField - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> String -- ^ package identifier, or GhcPkgId -> Text - -> m (Maybe Text) -findGhcPkgField menv wc pkgDbs name field = do + -> RIO env (Maybe Text) +findGhcPkgField wc pkgDbs name field = do result <- ghcPkg - menv wc pkgDbs ["field", "--simple-output", name, T.unpack field] return $ case result of Left{} -> Nothing - Right lbs -> - fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines lbs + Right bs -> + fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs -- | Get the version of the package -findGhcPkgVersion :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +findGhcPkgVersion :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageName - -> m (Maybe Version) -findGhcPkgVersion menv wc pkgDbs name = do - mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version" + -> RIO env (Maybe Version) +findGhcPkgVersion wc pkgDbs name = do + mv <- findGhcPkgField wc pkgDbs (packageNameString name) "version" case mv of Just !v -> return (parseVersion v) _ -> return Nothing -unregisterGhcPkgId :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler +unregisterGhcPkgId :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> CompilerVersion 'CVActual -> Path Abs Dir -- ^ package database -> GhcPkgId -> PackageIdentifier - -> m () -unregisterGhcPkgId menv wc cv pkgDb gid ident = do - eres <- ghcPkg menv wc [pkgDb] args + -> RIO env () +unregisterGhcPkgId wc cv pkgDb gid ident = do + eres <- ghcPkg wc [pkgDb] args case eres of - Left e -> logWarn $ T.pack $ show e + Left e -> logWarn $ displayShow e Right _ -> return () where -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead @@ -179,12 +174,11 @@ _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. -getCabalPkgVer :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride -> WhichCompiler -> m Version -getCabalPkgVer menv wc = do +getCabalPkgVer :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> RIO env Version +getCabalPkgVer wc = do logDebug "Getting Cabal package version" mres <- findGhcPkgVersion - menv wc [] -- global DB cabalPackageName diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -17,26 +17,28 @@ , ghci ) where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Control.Monad.State.Strict (State, execState, get, modify) import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LBS import Data.List -import Data.List.Extra (nubOrd) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE import qualified Distribution.PackageDescription as C -import qualified Distribution.Text as C import Path import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (withSystemTempDir) +import qualified RIO +import RIO.Process (HasProcessContext, exec, proc, readProcess_) import Stack.Build import Stack.Build.Installed import Stack.Build.Source import Stack.Build.Target import Stack.Config (getLocalPackages) import Stack.Constants.Config -import Stack.Exec import Stack.Ghci.Script import Stack.Package import Stack.PrettyPrint @@ -44,11 +46,13 @@ import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import System.IO (putStrLn, putStr, getLine) +import System.IO.Temp (getCanonicalTemporaryDirectory) #ifndef WINDOWS import qualified System.Posix.Files as Posix @@ -76,14 +80,22 @@ { ghciPkgName :: !PackageName , ghciPkgOpts :: ![(NamedComponent, BuildInfoOpts)] , ghciPkgDir :: !(Path Abs Dir) - , ghciPkgModules :: !(Set ModuleName) - , ghciPkgModFiles :: !(Set (Path Abs File)) -- ^ Module file paths. + , ghciPkgModules :: !ModuleMap , ghciPkgCFiles :: !(Set (Path Abs File)) -- ^ C files. , ghciPkgMainIs :: !(Map NamedComponent (Set (Path Abs File))) , ghciPkgTargetFiles :: !(Maybe (Set (Path Abs File))) , ghciPkgPackage :: !Package } deriving Show +-- Mapping from a module name to a map with all of the paths that use +-- that name. Each of those paths is associated with a set of components +-- that contain it. Purpose of this complex structure is for use in +-- 'checkForDuplicateModules'. +type ModuleMap = Map ModuleName (Map (Path Abs File) (Set (PackageName, NamedComponent))) + +unionModuleMaps :: [ModuleMap] -> ModuleMap +unionModuleMaps = M.unionsWith (M.unionWith S.union) + data GhciException = InvalidPackageOption String | LoadingDuplicateModules @@ -259,19 +271,18 @@ if (ghciSkipIntermediate && not ghciLoadLocalDeps) || null extraLoadDeps then return directlyWanted else do - let extraList = T.intercalate ", " (map (packageNameText . fst) extraLoadDeps) + let extraList = + mconcat $ intersperse ", " (map (RIO.display . fst) extraLoadDeps) if ghciLoadLocalDeps - then logInfo $ T.concat - [ "The following libraries will also be loaded into GHCi because " - , "they are local dependencies of your targets, and you specified --load-local-deps:\n " - , extraList - ] - else logInfo $ T.concat - [ "The following libraries will also be loaded into GHCi because " - , "they are intermediate dependencies of your targets:\n " - , extraList - , "\n(Use --skip-intermediate-deps to omit these)" - ] + then logInfo $ + "The following libraries will also be loaded into GHCi because " <> + "they are local dependencies of your targets, and you specified --load-local-deps:\n " <> + extraList + else logInfo $ + "The following libraries will also be loaded into GHCi because " <> + "they are intermediate dependencies of your targets:\n " <> + extraList <> + "\n(Use --skip-intermediate-deps to omit these)" return (directlyWanted ++ extraLoadDeps) getAllNonLocalTargets @@ -323,12 +334,13 @@ fromMaybe (not (null pkgs && null exposePackages)) ghciHidePackages hidePkgOpts = if shouldHidePackages - then "-hide-all-packages" : + then + ["-hide-all-packages"] ++ -- This is necessary, because current versions of ghci -- will entirely fail to start if base isn't visible. This -- is because it tries to use the interpreter to set -- buffering options on standard IO. - "-package" : "base" : + (if null targets then ["-package", "base"] else []) ++ concatMap (\n -> ["-package", packageNameString n]) exposePackages else [] oneWordOpts bio @@ -346,17 +358,17 @@ unless (null omittedOpts) $ logWarn ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> - T.unwords (map T.pack (nubOrd omittedOpts))) + mconcat (intersperse " " (fromString <$> nubOrd omittedOpts))) oiDir <- view objectInterfaceDirL let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ] - logInfo - ("Configuring GHCi with the following packages: " <> - T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) + logInfo $ + "Configuring GHCi with the following packages: " <> + mconcat (intersperse ", " (map (RIO.display . ghciPkgName) pkgs)) let execGhci extras = do - menv <- liftIO $ configEnvOverride config defaultEnvSettings - execSpawn menv + menv <- liftIO $ configProcessContextSettings config defaultEnvSettings + withProcessContext menv $ exec (fromMaybe (compilerExeName wc) ghciGhcCommand) (("--interactive" : ) $ -- This initial "-i" resets the include directories to @@ -372,37 +384,68 @@ -- multiple packages. case pkgs of [_] -> do - menv <- liftIO $ configEnvOverride config defaultEnvSettings - output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] + menv <- liftIO $ configProcessContextSettings config defaultEnvSettings + output <- withProcessContext menv + $ runGrabFirstLine (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] return $ "Intero" `isPrefixOf` output _ -> return False - withSystemTempDir "ghci" $ \tmpDirectory -> do - macrosOptions <- writeMacrosFile tmpDirectory pkgs - if ghciNoLoadModules - then execGhci macrosOptions - else do - checkForDuplicateModules pkgs - isIntero <- checkIsIntero - bopts <- view buildOptsL - mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs - scriptPath <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) - execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) + -- Since usage of 'exec' does not return, we cannot do any cleanup + -- on ghci exit. So, instead leave the generated files. To make this + -- more efficient and avoid gratuitous generation of garbage, the + -- file names are determined by hashing. This also has the nice side + -- effect of making it possible to copy the ghci invocation out of + -- the log and have it still work. + tmpDirectory <- + ( $(mkRelDir "haskell-stack-ghci")) <$> + (parseAbsDir =<< liftIO getCanonicalTemporaryDirectory) + ensureDir tmpDirectory + macrosOptions <- writeMacrosFile tmpDirectory pkgs + if ghciNoLoadModules + then execGhci macrosOptions + else do + checkForDuplicateModules pkgs + isIntero <- checkIsIntero + bopts <- view buildOptsL + mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs + scriptOptions <- writeGhciScript tmpDirectory (renderScript isIntero pkgs mainFile ghciOnlyMain extraFiles) + execGhci (macrosOptions ++ scriptOptions) -writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] -writeMacrosFile tmpDirectory packages = do - preprocessCabalMacros packages macrosFile - where - macrosFile = tmpDirectory $(mkRelFile "cabal_macros.h") +writeMacrosFile :: HasRunner env => Path Abs Dir -> [GhciPkgInfo] -> RIO env [String] +writeMacrosFile tmpDirectory pkgs = do + fps <- fmap (nubOrd . catMaybes . concat) $ + forM pkgs $ \pkg -> forM (ghciPkgOpts pkg) $ \(_, bio) -> do + let cabalMacros = bioCabalMacros bio + exists <- liftIO $ doesFileExist cabalMacros + if exists + then return $ Just cabalMacros + else do + prettyWarnL ["Didn't find expected autogen file:", display cabalMacros] + return Nothing + files <- liftIO $ mapM (S8.readFile . toFilePath) fps + if null files then return [] else do + out <- liftIO $ writeHashedFile tmpDirectory $(mkRelFile "cabal_macros.h") $ + S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files + return ["-optP-include", "-optP" <> toFilePath out] -writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m (Path Abs File) +writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m [String] writeGhciScript tmpDirectory script = do - liftIO $ scriptToFile scriptPath script + scriptPath <- liftIO $ writeHashedFile tmpDirectory $(mkRelFile "ghci-script") $ + LBS.toStrict $ scriptToLazyByteString script + let scriptFilePath = toFilePath scriptPath setScriptPerms scriptFilePath - return scriptPath - where - scriptPath = tmpDirectory $(mkRelFile "ghci-script") - scriptFilePath = toFilePath scriptPath + return ["-ghci-script=" <> scriptFilePath] +writeHashedFile :: Path Abs Dir -> Path Rel File -> ByteString -> IO (Path Abs File) +writeHashedFile tmpDirectory relFile contents = do + relSha <- shaPathForBytes contents + let outDir = tmpDirectory relSha + outFile = outDir relFile + alreadyExists <- doesFileExist outFile + unless alreadyExists $ do + ensureDir outDir + S8.writeFile (toFilePath outFile) contents + return outFile + renderScript :: Bool -> [GhciPkgInfo] -> Maybe (Path Abs File) -> Bool -> [Path Abs File] -> GhciScript renderScript isIntero pkgs mainFile onlyMain extraFiles = do let cdPhase = case (isIntero, pkgs) of @@ -416,7 +459,7 @@ Just path -> [Right path] _ -> [] modulePhase = cmdModule $ S.fromList allModules - allModules = concatMap (S.toList . ghciPkgModules) pkgs + allModules = nubOrd $ concatMap (M.keys . ghciPkgModules) pkgs case getFileTargets pkgs <> extraFiles of [] -> if onlyMain @@ -442,23 +485,23 @@ figureOutMainFile bopts mainIsTargets targets0 packages = do case candidates of [] -> return Nothing - [c@(_,_,fp)] -> do logInfo ("Using main module: " <> renderCandidate c) + [c@(_,_,fp)] -> do logInfo ("Using main module: " <> RIO.display (renderCandidate c)) return (Just fp) candidate:_ -> do borderedWarning $ do logWarn "The main module to load is ambiguous. Candidates are: " - forM_ (map renderCandidate candidates) logWarn + forM_ (map renderCandidate candidates) (logWarn . RIO.display) logWarn "You can specify which one to pick by: " logWarn (" * Specifying targets to stack ghci e.g. stack ghci " <> - sampleTargetArg candidate) + RIO.display ( sampleTargetArg candidate)) logWarn (" * Specifying what the main is e.g. stack ghci " <> - sampleMainIsArg candidate) + RIO.display (sampleMainIsArg candidate)) logWarn (" * Choosing from the candidate above [1.." <> - T.pack (show $ length candidates) <> "]") + RIO.display (length candidates) <> "]") liftIO userOption where targets = fromMaybe (M.fromList $ map (\(k, (_, x)) -> (k, x)) targets0) @@ -509,6 +552,7 @@ renderComp c = case c of CLib -> "lib" + CInternalLib name -> "internal-lib:" <> name CExe name -> "exe:" <> name CTest name -> "test:" <> name CBench name -> "bench:" <> name @@ -526,9 +570,7 @@ -> [(PackageName, (Path Abs File, Target))] -> RIO env [GhciPkgInfo] getGhciPkgInfos buildOptsCLI sourceMap addPkgs mfileTargets localTargets = do - menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled - menv GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False @@ -602,8 +644,9 @@ { ghciPkgName = packageName pkg , ghciPkgOpts = M.toList filteredOpts , ghciPkgDir = parent cabalfp - , ghciPkgModules = mconcat (M.elems (filterWanted mods)) - , ghciPkgModFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalModulePath) files))) + , ghciPkgModules = unionModuleMaps $ + map (\(comp, mp) -> M.map (\fp -> M.singleton fp (S.singleton (packageName pkg, comp))) mp) + (M.toList (filterWanted mods)) , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) files , ghciPkgCFiles = mconcat (M.elems (filterWanted (M.map (setMapMaybe dotCabalCFilePath) files))) , ghciPkgTargetFiles = mfileTargets >>= M.lookup name @@ -624,13 +667,13 @@ (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else []) wantedPackageComponents _ _ _ = S.empty -checkForIssues :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForIssues :: HasLogFunc env => [GhciPkgInfo] -> RIO env () checkForIssues pkgs = do unless (null issues) $ borderedWarning $ do logWarn "Warning: There are cabal settings for this project which may prevent GHCi from loading your code properly." logWarn "In some cases it can also load some projects which would otherwise fail to build." logWarn "" - mapM_ logWarn $ intercalate [""] issues + mapM_ (logWarn . RIO.display) $ intercalate [""] issues logWarn "" logWarn "To resolve, remove the flag(s) from the cabal file(s) and instead put them at the top of the haskell files." logWarn "" @@ -687,7 +730,7 @@ , (c, bio) <- ghciPkgOpts pkg ] -borderedWarning :: MonadLogger m => m a -> m a +borderedWarning :: HasLogFunc env => RIO env a -> RIO env a borderedWarning f = do logWarn "" logWarn "* * * * * * * *" @@ -696,20 +739,28 @@ logWarn "" return x -checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +-- TODO: Should this also tell the user the filepaths, not just the +-- module name? +checkForDuplicateModules :: HasRunner env => [GhciPkgInfo] -> RIO env () checkForDuplicateModules pkgs = do unless (null duplicates) $ do borderedWarning $ do - logWarn "The following modules are present in multiple packages:" - forM_ duplicates $ \(mn, pns) -> do - logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")") + prettyError $ "Multiple files use the same module name:" <> + line <> bulletedList (map prettyDuplicate duplicates) throwM LoadingDuplicateModules where - duplicates, allModules :: [(String, [PackageName])] - duplicates = filter (not . null . tail . snd) allModules - allModules = - M.toList $ M.fromListWith (++) $ - concatMap (\pkg -> map ((, [ghciPkgName pkg]) . C.display) (S.toList (ghciPkgModules pkg))) pkgs + duplicates :: [(ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent)))] + duplicates = + filter (\(_, mp) -> M.size mp > 1) $ + M.toList $ + unionModuleMaps (map ghciPkgModules pkgs) + prettyDuplicate :: (ModuleName, Map (Path Abs File) (Set (PackageName, NamedComponent))) -> AnsiDoc + prettyDuplicate (mn, mp) = + styleError (display mn) <+> "found at the following paths" <> line <> + bulletedList (map fileDuplicate (M.toList mp)) + fileDuplicate :: (Path Abs File, Set (PackageName, NamedComponent)) -> AnsiDoc + fileDuplicate (fp, comps) = + display fp <+> parens (fillSep (punctuate "," (map display (S.toList comps)))) targetWarnings :: HasRunner env @@ -730,17 +781,19 @@ , flow "It can still be useful to specify these, as they will be passed to ghci via -package flags." ] when (null localTargets && isNothing mfileTargets) $ - prettyWarn $ vsep - [ flow "No local targets specified, so ghci will not use any options from your package.yaml / *.cabal files." + prettyNote $ vsep + [ flow "No local targets specified, so a plain ghci will be started with no package hiding or package options." , "" - , flow "Potential ways to resolve this:" + , flow "If you want to use package hiding and options, then you can try one of the following:" + , "" , bulletedList [ fillSep - [ flow "If you want to use the package.yaml / *.cabal package in the current directory, use" + [ flow "If you want to start a different project configuration than" <+> display stackYaml <> ", then you can use" , styleShell "stack init" - , flow "to create a new stack.yaml." + , flow "to create a new stack.yaml for the packages in the current directory." + , line ] - , flow "Add to the 'packages' field of" <+> display stackYaml + , flow "If you want to use the project configuration at" <+> display stackYaml <> ", then you can add to its 'packages' field." ] , "" ] @@ -788,14 +841,6 @@ (_, Just PSIndex{}) -> return loadAllDeps (_, _) -> return False -preprocessCabalMacros :: MonadIO m => [GhciPkgInfo] -> Path Abs File -> m [String] -preprocessCabalMacros pkgs out = liftIO $ do - let fps = nubOrd (concatMap (mapMaybe (bioCabalMacros . snd) . ghciPkgOpts) pkgs) - files <- mapM (S8.readFile . toFilePath) fps - if null files then return [] else do - S8.writeFile (toFilePath out) $ S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n#undef CURRENT_COMPONENT_ID\n") files - return ["-optP-include", "-optP" <> toFilePath out] - setScriptPerms :: MonadIO m => FilePath -> m () #ifdef WINDOWS setScriptPerms _ = do @@ -826,46 +871,16 @@ TargetAll ProjectPackage -> True _ -> False - -{- Copied from Stack.Ide, may be useful in the future - --- | Get options and target files for the given package info. -getPackageOptsAndTargetFiles - :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env) - => Path Abs Dir -> GhciPkgInfo -> m ([FilePath], [FilePath]) -getPackageOptsAndTargetFiles pwd pkg = do - dist <- distDirFromDir (ghciPkgDir pkg) - let autogen = autogenDir dist - paths_foo <- - liftM - (autogen ) - (parseRelFile - ("Paths_" ++ packageNameString (ghciPkgName pkg) ++ ".hs")) - paths_foo_exists <- doesFileExist paths_foo - let ghcOptions bio = - bioOneWordOpts bio ++ - bioOpts bio ++ - bioPackageFlags bio ++ - maybe [] (\cabalMacros -> ["-optP-include", "-optP" <> toFilePath cabalMacros]) (bioCabalMacros bio) +-- | Run a command and grab the first line of stdout, dropping +-- stderr's contexts completely. +runGrabFirstLine :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env String +runGrabFirstLine cmd0 args = + proc cmd0 args $ \pc -> do + (out, _err) <- readProcess_ pc return - ( ("--dist-dir=" <> toFilePathNoTrailingSep dist) : - -- FIXME: use compilerOptionsCabalFlag - map ("--ghc-option=" ++) (concatMap (ghcOptions . snd) (ghciPkgOpts pkg)) - , mapMaybe - (fmap toFilePath . stripProperPrefix pwd) - (S.toList (ghciPkgCFiles pkg) <> S.toList (ghciPkgModFiles pkg) <> - [paths_foo | paths_foo_exists])) - --- | List load targets for a package target. -targetsCmd :: Text -> GlobalOpts -> IO () -targetsCmd target go@GlobalOpts{..} = - withBuildConfig go $ - do let boptsCli = defaultBuildOptsCLI { boptsCLITargets = [target] } - (_realTargets,_,pkgs) <- ghciSetup (ideGhciOpts boptsCli) - pwd <- getCurrentDir - targets <- - fmap - (concat . snd . unzip) - (mapM (getPackageOptsAndTargetFiles pwd) pkgs) - forM_ targets (liftIO . putStrLn) --} + $ TL.unpack + $ TL.filter (/= '\r') + $ TL.concat + $ take 1 + $ TL.lines + $ TLE.decodeUtf8With lenientDecode out diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -14,22 +14,22 @@ , scriptToFile ) where -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Builder +import Data.ByteString.Builder (toLazyByteString) import Data.List import qualified Data.Set as S -import Data.Text.Encoding (encodeUtf8Builder) import Path -import Stack.Prelude hiding (ByteString) +import Stack.Prelude import System.IO (BufferMode (..), hSetBinaryMode) import Distribution.ModuleName hiding (toFilePath) newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] } +instance Semigroup GhciScript where + GhciScript xs <> GhciScript ys = GhciScript (ys <> xs) instance Monoid GhciScript where mempty = GhciScript [] - (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs) + mappend = (<>) data GhciCommand = Add (Set (Either ModuleName (Path Abs File))) @@ -46,7 +46,7 @@ cmdModule :: Set ModuleName -> GhciScript cmdModule = GhciScript . (:[]) . Module -scriptToLazyByteString :: GhciScript -> ByteString +scriptToLazyByteString :: GhciScript -> LByteString scriptToLazyByteString = toLazyByteString . scriptToBuilder scriptToBuilder :: GhciScript -> Builder @@ -65,30 +65,27 @@ -- Command conversion -fromText :: Text -> Builder -fromText = encodeUtf8Builder - commandToBuilder :: GhciCommand -> Builder commandToBuilder (Add modules) | S.null modules = mempty | otherwise = - fromText ":add " - <> mconcat (intersperse (fromText " ") $ - fmap (stringUtf8 . quoteFileName . either (mconcat . intersperse "." . components) toFilePath) + ":add " + <> mconcat (intersperse " " $ + fmap (fromString . quoteFileName . either (mconcat . intersperse "." . components) toFilePath) (S.toAscList modules)) - <> fromText "\n" + <> "\n" commandToBuilder (CdGhc path) = - fromText ":cd-ghc " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" + ":cd-ghc " <> fromString (quoteFileName (toFilePath path)) <> "\n" commandToBuilder (Module modules) - | S.null modules = fromText ":module +\n" + | S.null modules = ":module +\n" | otherwise = - fromText ":module + " - <> mconcat (intersperse (fromText " ") - $ (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) <$> S.toAscList modules) - <> fromText "\n" + ":module + " + <> mconcat (intersperse " " + $ fromString . quoteFileName . mconcat . intersperse "." . components <$> S.toAscList modules) + <> "\n" -- | Make sure that a filename with spaces in it gets the proper quotes. quoteFileName :: String -> String diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -9,12 +9,12 @@ ) where import Stack.Prelude -import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) import Data.List (find) import qualified Data.Set as Set import qualified Data.Text as T -import Lens.Micro +import Path (parseAbsFile) import Path.IO hiding (findExecutable) import qualified Stack.Build import Stack.Fetch @@ -24,16 +24,20 @@ import Stack.Types.PackageName import Stack.Types.Version import System.Exit -import System.Process.Read (resetExeCache, tryProcessStdout, findExecutable) -import System.Process.Run +import RIO.Process -- | Hoogle command. -hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO () -hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do +hoogleCmd :: ([String],Bool,Bool,Bool) -> GlobalOpts -> IO () +hoogleCmd (args,setup,rebuild,startServer) go = withBuildConfig go $ do hooglePath <- ensureHoogleInPath generateDbIfNeeded hooglePath - runHoogle hooglePath args + runHoogle hooglePath args' where + args' :: [String] + args' = if startServer + then ["server", "--local", "--port", "8080"] + else [] + ++ args generateDbIfNeeded :: Path Abs File -> RIO EnvConfig () generateDbIfNeeded hooglePath = do databaseExists <- checkDatabaseExists @@ -104,18 +108,18 @@ | ver >= hoogleMinVersion -> Right ident _ -> Left hoogleMinIdent) case hooglePackageIdentifier of - Left{} -> - logInfo - ("Minimum " <> packageIdentifierText hoogleMinIdent <> - " is not in your index. Installing the minimum version.") - Right ident -> - logInfo - ("Minimum version is " <> packageIdentifierText hoogleMinIdent <> - ". Found acceptable " <> - packageIdentifierText ident <> - " in your index, installing it.") + Left{} -> logInfo $ + "Minimum " <> + display hoogleMinIdent <> + " is not in your index. Installing the minimum version." + Right ident -> logInfo $ + "Minimum version is " <> + display hoogleMinIdent <> + ". Found acceptable " <> + display ident <> + " in your index, installing it." config <- view configL - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configProcessContextSettings config envSettings liftIO (catch (withBuildConfigAndLock @@ -133,22 +137,18 @@ })) (\(e :: ExitCode) -> case e of - ExitSuccess -> resetExeCache menv + ExitSuccess -> runRIO menv resetExeCache _ -> throwIO e)) runHoogle :: Path Abs File -> [String] -> RIO EnvConfig () runHoogle hooglePath hoogleArgs = do config <- view configL - menv <- liftIO $ configEnvOverride config envSettings + menv <- liftIO $ configProcessContextSettings config envSettings dbpath <- hoogleDatabasePath let databaseArg = ["--database=" ++ toFilePath dbpath] - runCmd - Cmd - { cmdDirectoryToRunIn = Nothing - , cmdCommandToRun = toFilePath hooglePath - , cmdEnvOverride = menv - , cmdCommandLineArguments = hoogleArgs ++ databaseArg - } - Nothing + withProcessContext menv $ proc + (toFilePath hooglePath) + (hoogleArgs ++ databaseArg) + runProcess_ bail :: RIO EnvConfig a bail = liftIO (exitWith (ExitFailure (-1))) checkDatabaseExists = do @@ -157,45 +157,47 @@ ensureHoogleInPath :: RIO EnvConfig (Path Abs File) ensureHoogleInPath = do config <- view configL - menv <- liftIO $ configEnvOverride config envSettings - mhooglePath <- findExecutable menv "hoogle" + menv <- liftIO $ configProcessContextSettings config envSettings + mhooglePath <- runRIO menv $ findExecutable "hoogle" eres <- case mhooglePath of - Nothing -> return $ Left "Hoogle isn't installed." - Just hooglePath -> do - result <- tryProcessStdout Nothing menv (toFilePath hooglePath) ["--numeric-version"] + Left _ -> return $ Left "Hoogle isn't installed." + Right hooglePath -> do + result <- withProcessContext menv + $ proc hooglePath ["--numeric-version"] + $ tryAny . readProcessStdout_ let unexpectedResult got = Left $ T.concat [ "'" - , T.pack (toFilePath hooglePath) + , T.pack hooglePath , " --numeric-version' did not respond with expected value. Got: " , got ] return $ case result of Left err -> unexpectedResult $ T.pack (show err) - Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (S8.unpack bs)) of - Nothing -> unexpectedResult $ T.pack (S8.unpack bs) + Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (BL8.unpack bs)) of + Nothing -> unexpectedResult $ T.pack (BL8.unpack bs) Just ver | ver >= hoogleMinVersion -> Right hooglePath | otherwise -> Left $ T.concat [ "Installed Hoogle is too old, " - , T.pack (toFilePath hooglePath) + , T.pack hooglePath , " is version " , versionText ver , " but >= 5.0 is required." ] case eres of - Right hooglePath -> return hooglePath + Right hooglePath -> parseAbsFile hooglePath Left err | setup -> do - logWarn $ err <> " Automatically installing (use --no-setup to disable) ..." + logWarn $ display err <> " Automatically installing (use --no-setup to disable) ..." installHoogle - mhooglePath' <- findExecutable menv "hoogle" + mhooglePath' <- runRIO menv $ findExecutable "hoogle" case mhooglePath' of - Just hooglePath -> return hooglePath - Nothing -> do + Right hooglePath -> parseAbsFile hooglePath + Left _ -> do logWarn "Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug." bail | otherwise -> do - logWarn $ err <> " Not installing it due to --no-setup." + logWarn $ display err <> " Not installing it due to --no-setup." bail envSettings = EnvSettings diff --git a/src/Stack/IDE.hs b/src/Stack/IDE.hs --- a/src/Stack/IDE.hs +++ b/src/Stack/IDE.hs @@ -17,8 +17,7 @@ import Stack.Package (readPackageUnresolvedDir, gpdPackageName) import Stack.Prelude import Stack.Types.Config -import Stack.Types.Package -import Stack.Types.PackageName +import Stack.Types.NamedComponent -- | List the packages inside the current project. listPackages :: HasEnvConfig env => RIO env () @@ -29,13 +28,13 @@ packageDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages forM_ packageDirs $ \dir -> do (gpd, _) <- readPackageUnresolvedDir dir False - (logInfo . packageNameText) (gpdPackageName gpd) + (logInfo . display) (gpdPackageName gpd) -- | List the targets in the current project. listTargets :: HasEnvConfig env => RIO env () listTargets = do rawLocals <- lpProject <$> getLocalPackages - logInfo + logInfo $ display (T.intercalate "\n" (map diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -25,7 +25,7 @@ import Stack.PrettyPrint import Stack.Types.Config import Stack.Types.Image -import System.Process.Run +import RIO.Process -- | Stages the executables & additional content in a staging -- directory under '.stack-work' @@ -130,8 +130,7 @@ createDockerImage :: HasConfig env => ImageDockerOpts -> Path Abs Dir -> RIO env () -createDockerImage dockerConfig dir = do - menv <- getMinimalEnvOverride +createDockerImage dockerConfig dir = case imgDockerBase dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do @@ -146,14 +145,13 @@ (imageName (parent . parent . parent $ dir)) (imgDockerImageName dockerConfig) , toFilePathNoTrailingSep dir] - callProcess (Cmd Nothing "docker" menv args) + proc "docker" args runProcess_ -- | Extend the general purpose docker image with entrypoints (if specified). extendDockerImageWithEntrypoint :: HasConfig env => ImageDockerOpts -> Path Abs Dir -> RIO env () extendDockerImageWithEntrypoint dockerConfig dir = do - menv <- getMinimalEnvOverride let dockerImageName = fromMaybe (imageName (parent . parent . parent $ dir)) @@ -174,15 +172,13 @@ , "ENTRYPOINT [\"/usr/local/bin/" ++ ep ++ "\"]" , "CMD []"])))) - callProcess - (Cmd - Nothing + proc "docker" - menv [ "build" , "-t" , dockerImageName ++ "-" ++ ep - , toFilePathNoTrailingSep dir])) + , toFilePathNoTrailingSep dir] + runProcess_) -- | Fail with friendly error if project root not set. fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -72,7 +72,7 @@ find = findCabalDirs (includeSubDirs initOpts) dirs' = if null dirs then [currDir] else dirs logInfo "Looking for .cabal or package.yaml files to use to init the project." - cabaldirs <- (Set.toList . Set.unions) <$> mapM find dirs' + cabaldirs <- Set.toList . Set.unions <$> mapM find dirs' (bundle, dupPkgs) <- cabalPackagesCheck cabaldirs noPkgMsg Nothing (sd, flags, extraDeps, rbundle) <- getDefaultResolver whichCmd dest initOpts @@ -139,31 +139,31 @@ toPkg dir = PLFilePath $ makeRelDir dir indent t = T.unlines $ fmap (" " <>) (T.lines t) - logInfo $ "Initialising configuration using resolver: " <> sdResolverName sd + logInfo $ "Initialising configuration using resolver: " <> display (sdResolverName sd) logInfo $ "Total number of user packages considered: " - <> T.pack (show (Map.size bundle + length dupPkgs)) + <> display (Map.size bundle + length dupPkgs) when (dupPkgs /= []) $ do logWarn $ "Warning! Ignoring " - <> T.pack (show $ length dupPkgs) + <> displayShow (length dupPkgs) <> " duplicate packages:" rels <- mapM makeRel dupPkgs - logWarn $ indent $ showItems rels + logWarn $ display $ indent $ showItems rels when (Map.size ignored > 0) $ do logWarn $ "Warning! Ignoring " - <> T.pack (show $ Map.size ignored) + <> displayShow (Map.size ignored) <> " packages due to dependency conflicts:" rels <- mapM makeRel (Map.elems (fmap fst ignored)) - logWarn $ indent $ showItems rels + logWarn $ display $ indent $ showItems rels when (Map.size extraDeps > 0) $ do - logWarn $ "Warning! " <> T.pack (show $ Map.size extraDeps) + logWarn $ "Warning! " <> displayShow (Map.size extraDeps) <> " external dependencies were added." logInfo $ (if exists then "Overwriting existing configuration file: " else "Writing configuration to file: ") - <> T.pack reldest + <> fromString reldest liftIO $ L.writeFile (toFilePath dest) $ B.toLazyByteString $ renderStackYaml p @@ -239,7 +239,7 @@ [ ("user-message" , userMsgHelp) , ("resolver" , resolverHelp) , ("packages" , packageHelp) - , ("extra-deps" , "# Dependency packages to be pulled from upstream that are not in the resolver\n# (e.g., acme-missiles-0.3)") + , ("extra-deps" , "# Dependency packages to be pulled from upstream that are not in the resolver\n# using the same syntax as the packages field.\n# (e.g., acme-missiles-0.3)") , ("flags" , "# Override default flag values for local packages and extra-deps") , ("extra-package-dbs", "# Extra package databases containing global packages") ] @@ -262,9 +262,12 @@ , "resolver: nightly-2015-09-21" , "resolver: ghc-7.10.2" , "resolver: ghcjs-0.1.0_ghc-7.10.2" - , "resolver:" - , " name: custom-snapshot" - , " location: \"./custom-snapshot.yaml\"" + , "" + , "The location of a snapshot can be provided as a file or url. Stack assumes" + , "a snapshot provided as a file might change, whereas a url resource does not." + , "" + , "resolver: ./custom-snapshot.yaml" + , "resolver: https://example.com/snapshots/2018-01-01.yaml" ] userMsgHelp = commentHelp @@ -281,14 +284,9 @@ , " git: https://github.com/commercialhaskell/stack.git" , " commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a" , "- location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a" - , " extra-dep: true" , " subdirs:" , " - auto-update" , " - wai" - , "" - , "A package marked 'extra-dep: true' will only be built if demanded by a" - , "non-dependency (i.e. a user package), and its test suites and benchmarks" - , "will not be run. This is useful for tweaking upstream packages." ] footerHelp = @@ -331,7 +329,7 @@ logError "" logError " http://docs.haskellstack.org/en/stable/yaml_configuration/" logError "" - logError $ "Exception was: " <> T.pack (show e) + logError $ "Exception was: " <> displayShow e throwString "" -- | Get the default resolver value @@ -385,7 +383,7 @@ -- , Extra dependencies -- , Src packages actually considered) getWorkingResolverPlan whichCmd stackYaml initOpts bundle sd = do - logInfo $ "Selected resolver: " <> sdResolverName sd + logInfo $ "Selected resolver: " <> display (sdResolverName sd) go bundle where go info = do @@ -405,13 +403,13 @@ if length ignored > 1 then do logWarn "*** Ignoring packages:" - logWarn $ indent $ showItems ignored + logWarn $ display $ indent $ showItems ignored else logWarn $ "*** Ignoring package: " - <> T.pack (packageNameString - (case ignored of - [] -> error "getWorkingResolverPlan.head" - x:_ -> x)) + <> display + (case ignored of + [] -> error "getWorkingResolverPlan.head" + x:_ -> x) go available where @@ -454,17 +452,17 @@ BuildPlanCheckFail _ e _ | omitPackages initOpts -> do logWarn $ "*** Resolver compiler mismatch: " - <> sdResolverName sd - logWarn $ indent $ T.pack $ show result + <> display (sdResolverName sd) + logWarn $ display $ indent $ T.pack $ show result return $ Left $ failedUserPkgs e | 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 " <> sdResolverName sd + logWarn $ "*** Resolver " <> display (sdResolverName sd) <> " will need external packages: " - logWarn $ indent $ T.pack $ show res + logWarn $ display $ indent $ T.pack $ show res failedUserPkgs e = Map.keys $ Map.unions (Map.elems (fmap deNeededBy e)) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Ls.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Stack.Ls + ( lsCmd + , lsParser + , listDependenciesCmd + ) where + +import Control.Exception (Exception, throw) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (MonadReader) +import Control.Monad (when) +import Data.Aeson +import Stack.Prelude +import Stack.Types.Runner +import qualified Data.Aeson.Types as A +import qualified Data.List as L +import Data.Text hiding (pack, intercalate) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Network.HTTP.StackClient (httpJSON) +import Network.HTTP.Simple + (addRequestHeader, getResponseBody, parseRequest, + setRequestManager) +import Network.HTTP.Types.Header (hAccept) +import qualified Options.Applicative as OA +import Options.Applicative ((<|>)) +import Path +import Stack.Runners (withBuildConfig, withBuildConfigDot) +import Stack.Types.Config +import Stack.Dot +import Stack.Options.DotParser (listDepsOptsParser) +import System.Process.PagerEditor (pageText) +import System.Directory (listDirectory) +import System.IO (stderr, hPutStrLn) +import Network.HTTP.Client.TLS (getGlobalManager) + +data LsView + = Local + | Remote + deriving (Show, Eq, Ord) + +data SnapshotType + = Lts + | Nightly + deriving (Show, Eq, Ord) + +data LsCmds + = LsSnapshot SnapshotOpts + | LsDependencies ListDepsOpts + +data SnapshotOpts = SnapshotOpts + { soptViewType :: LsView + , soptLtsSnapView :: Bool + , soptNightlySnapView :: Bool + } deriving (Eq, Show, Ord) + +newtype LsCmdOpts = LsCmdOpts + { lsView :: LsCmds + } + +lsParser :: OA.Parser LsCmdOpts +lsParser = LsCmdOpts <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd) + +lsCmdOptsParser :: OA.Parser LsCmds +lsCmdOptsParser = LsSnapshot <$> lsViewSnapCmd + +lsDepOptsParser :: OA.Parser LsCmds +lsDepOptsParser = LsDependencies <$> listDepsOptsParser + +lsViewSnapCmd :: OA.Parser SnapshotOpts +lsViewSnapCmd = + SnapshotOpts <$> + (OA.hsubparser (lsViewRemoteCmd <> lsViewLocalCmd) <|> pure Local) <*> + OA.switch + (OA.long "lts" <> OA.short 'l' <> OA.help "Only show lts snapshots") <*> + OA.switch + (OA.long "nightly" <> OA.short 'n' <> + OA.help "Only show nightly snapshots") + +lsSnapCmd :: OA.Mod OA.CommandFields LsCmds +lsSnapCmd = + OA.command + "snapshots" + (OA.info + lsCmdOptsParser + (OA.progDesc "View local snapshot (default option)")) + +lsDepsCmd :: OA.Mod OA.CommandFields LsCmds +lsDepsCmd = + OA.command + "dependencies" + (OA.info lsDepOptsParser (OA.progDesc "View the dependencies")) + +data Snapshot = Snapshot + { snapId :: Text + , snapTitle :: Text + , snapTime :: Text + } deriving (Show, Eq, Ord) + +data SnapshotData = SnapshotData + { _snapTotalCounts :: Integer + , snaps :: [[Snapshot]] + } deriving (Show, Eq, Ord) + +instance FromJSON Snapshot where + parseJSON o@(Array _) = parseSnapshot o + parseJSON _ = mempty + +instance FromJSON SnapshotData where + parseJSON (Object s) = + SnapshotData <$> s .: "totalCount" <*> s .: "snapshots" + parseJSON _ = mempty + +toSnapshot :: [Value] -> Snapshot +toSnapshot [String sid, String stitle, String stime] = + Snapshot + { snapId = sid + , snapTitle = stitle + , snapTime = stime + } +toSnapshot val = throw $ ParseFailure val + +newtype LsException = + ParseFailure [Value] + deriving (Show, Typeable) + +instance Exception LsException + +parseSnapshot :: Value -> A.Parser Snapshot +parseSnapshot = A.withArray "array of snapshot" (return . toSnapshot . V.toList) + +displayTime :: Snapshot -> [Text] +displayTime Snapshot {..} = [snapTime] + +displaySnap :: Snapshot -> [Text] +displaySnap Snapshot {..} = + ["Resolver name: " <> snapId, "\n" <> snapTitle <> "\n\n"] + +displaySingleSnap :: [Snapshot] -> Text +displaySingleSnap snapshots = + case snapshots of + [] -> mempty + (x:xs) -> + let snaps = + displayTime x <> ["\n\n"] <> displaySnap x <> + L.concatMap displaySnap xs + in T.concat snaps + +renderData :: Bool -> Text -> IO () +renderData True content = pageText content +renderData False content = T.putStr content + +displaySnapshotData :: Bool -> SnapshotData -> IO () +displaySnapshotData term sdata = + case L.reverse $ snaps sdata of + [] -> return () + xs -> + let snaps = T.concat $ L.map displaySingleSnap xs + in renderData term snaps + +filterSnapshotData :: SnapshotData -> SnapshotType -> SnapshotData +filterSnapshotData sdata stype = + sdata + { snaps = filterSnapData + } + where + snapdata = snaps sdata + filterSnapData = + case stype of + Lts -> L.map (L.filter (\x -> "lts" `isPrefixOf` snapId x)) snapdata + Nightly -> + L.map (L.filter (\x -> "nightly" `isPrefixOf` snapId x)) snapdata + +displayLocalSnapshot :: Bool -> [String] -> IO () +displayLocalSnapshot term xs = renderData term (localSnaptoText xs) + +localSnaptoText :: [String] -> Text +localSnaptoText xs = T.intercalate "\n" $ L.map T.pack xs + +handleLocal + :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) + => LsCmdOpts -> m () +handleLocal lsOpts = do + (instRoot :: Path Abs Dir) <- installationRootDeps + isStdoutTerminal <- view terminalL + let snapRootDir = parent $ parent instRoot + snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir + let snapData = L.sort snapData' + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case (soptLtsSnapView, soptNightlySnapView) of + (True, False) -> + liftIO $ + displayLocalSnapshot isStdoutTerminal $ + L.filter (L.isPrefixOf "lts") snapData + (False, True) -> + liftIO $ + displayLocalSnapshot isStdoutTerminal $ + L.filter (L.isPrefixOf "night") snapData + _ -> liftIO $ displayLocalSnapshot isStdoutTerminal snapData + LsDependencies _ -> return () + +handleRemote + :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) + => LsCmdOpts -> m () +handleRemote lsOpts = do + req <- liftIO $ parseRequest urlInfo + mgr <- liftIO getGlobalManager + isStdoutTerminal <- view terminalL + let req' = + setRequestManager mgr $ + addRequestHeader hAccept "application/json" req + result <- httpJSON req' + let snapData = getResponseBody result + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case (soptLtsSnapView, soptNightlySnapView) of + (True, False) -> + liftIO $ + displaySnapshotData isStdoutTerminal $ + filterSnapshotData snapData Lts + (False, True) -> + liftIO $ + displaySnapshotData isStdoutTerminal $ + filterSnapshotData snapData Nightly + _ -> liftIO $ displaySnapshotData isStdoutTerminal snapData + LsDependencies _ -> return () + where + urlInfo = "https://www.stackage.org/snapshots" + +lsCmd :: LsCmdOpts -> GlobalOpts -> IO () +lsCmd lsOpts go = + case lsView lsOpts of + LsSnapshot SnapshotOpts {..} -> + case soptViewType of + Local -> withBuildConfig go (handleLocal lsOpts) + Remote -> withBuildConfig go (handleRemote lsOpts) + LsDependencies depOpts -> listDependenciesCmd False depOpts go + +-- | List the dependencies +listDependenciesCmd :: Bool -> ListDepsOpts -> GlobalOpts -> IO () +listDependenciesCmd deprecated opts go = do + when + deprecated + (hPutStrLn + stderr + "DEPRECATED: Use ls dependencies instead. Will be removed in next major version.") + withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts + +lsViewLocalCmd :: OA.Mod OA.CommandFields LsView +lsViewLocalCmd = + OA.command + "local" + (OA.info (pure Local) (OA.progDesc "View local snapshot")) + +lsViewRemoteCmd :: OA.Mod OA.CommandFields LsView +lsViewRemoteCmd = + OA.command + "remote" + (OA.info (pure Remote) (OA.progDesc "View remote snapshot")) diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -34,12 +34,11 @@ import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T (lenientDecode) import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as LT import Data.Time.Calendar import Data.Time.Clock import qualified Data.Yaml as Yaml import Network.HTTP.Download -import Network.HTTP.Simple +import Network.HTTP.Simple (Request, HttpException, getResponseStatusCode, getResponseBody) import Path import Path.IO import Stack.Constants @@ -47,9 +46,9 @@ import Stack.Types.Config import Stack.Types.PackageName import Stack.Types.TemplateName -import System.Process.Run -import Text.Hastache -import Text.Hastache.Context +import RIO.Process +import qualified Text.Mustache as Mustache +import qualified Text.Mustache.Render as Mustache import Text.Printf import Text.ProjectTemplate @@ -107,12 +106,12 @@ RemoteTemp -> "Downloading" in logInfo - (loading <> " template \"" <> templateName template <> + (loading <> " template \"" <> display (templateName template) <> "\" to create project \"" <> - packageNameText project <> + display (packageNameText project) <> "\" in " <> if bare then "the current directory" - else T.pack (toFilePath (dirname absDir)) <> + else fromString (toFilePath (dirname absDir)) <> " ...") data TemplateFrom = LocalTemp | RemoteTemp @@ -145,7 +144,7 @@ where loadLocalFile :: Path b File -> RIO env Text loadLocalFile path = do - logDebug ("Opening local template: \"" <> T.pack (toFilePath path) + logDebug ("Opening local template: \"" <> fromString (toFilePath path) <> "\"") exists <- doesFileExist path if exists @@ -176,28 +175,28 @@ config <- view configL currentYear <- do now <- liftIO getCurrentTime - (year, _, _) <- return $ toGregorian . utctDay $ now + let (year, _, _) = toGregorian (utctDay now) return $ T.pack . show $ year - let context = M.union (M.union nonceParams extraParams) configParams + let context = M.unions [nonceParams, nameParams, configParams, yearParam] where nameAsVarId = T.replace "-" "_" $ packageNameText project nameAsModule = T.filter (/= '-') $ T.toTitle $ packageNameText project - extraParams = M.fromList [ ("name", packageNameText project) - , ("name-as-varid", nameAsVarId) - , ("name-as-module", nameAsModule) - , ("year", currentYear) ] + nameParams = M.fromList [ ("name", packageNameText project) + , ("name-as-varid", nameAsVarId) + , ("name-as-module", nameAsModule) ] configParams = configTemplateParams config - (applied,missingKeys) <- - runWriterT - (hastacheStr - defaultConfig { muEscapeFunc = id } - templateText - (mkStrContextM (contextFunction context))) + yearParam = M.singleton "year" currentYear + etemplateCompiled = Mustache.compileTemplate (T.unpack (templateName template)) templateText + templateCompiled <- case etemplateCompiled of + Left e -> throwM $ InvalidTemplate template (show e) + Right t -> return t + let (substitutionErrors, applied) = Mustache.checkedSubstitute templateCompiled context + missingKeys = S.fromList $ concatMap onlyMissingKeys substitutionErrors unless (S.null missingKeys) - (logInfo ("\n" <> T.pack (show (MissingParameters project template missingKeys (configUserConfigPath config))) <> "\n")) + (logInfo ("\n" <> displayShow (MissingParameters project template missingKeys (configUserConfigPath config)) <> "\n")) files :: Map FilePath LB.ByteString <- - catch (execWriterT $ - yield (T.encodeUtf8 (LT.toStrict applied)) $$ + catch (execWriterT $ runConduit $ + yield (T.encodeUtf8 applied) .| unpackTemplate receiveMem id ) (\(e :: ProjectTemplateException) -> @@ -217,20 +216,8 @@ return (dir path, bytes)) (M.toList files)) where - -- | Does a lookup in the context and returns a moustache value, - -- on the side, writes out a set of keys that were requested but - -- not found. - contextFunction - :: Monad m - => Map Text Text - -> String - -> WriterT (Set String) m (MuType (WriterT (Set String) m)) - contextFunction context key = - case M.lookup (T.pack key) context of - Nothing -> do - tell (S.singleton key) - return MuNothing - Just value -> return (MuVariable value) + onlyMissingKeys (Mustache.VariableNotFound ks) = map T.unpack ks + onlyMissingKeys _ = [] -- | Check if we're going to overwrite any existing files. checkForOverwrite :: (MonadIO m, MonadThrow m) => [Path Abs File] -> m () @@ -252,16 +239,16 @@ -- | Run any initialization functions, such as Git. runTemplateInits :: HasConfig env - => Path Abs Dir -> RIO env () + => Path Abs Dir + -> RIO env () runTemplateInits dir = do - menv <- getMinimalEnvOverride config <- view configL case configScmInit config of Nothing -> return () Just Git -> - catch (callProcess $ Cmd (Just dir) "git" menv ["init"]) - (\(_ :: ProcessExitedUnsuccessfully) -> - logInfo "git init failed to run, ignoring ...") + withWorkingDir (toFilePath dir) $ + catchAny (proc "git" ["init"] runProcess_) + (\_ -> logInfo "git init failed to run, ignoring ...") -- | Display the set of templates accompanied with description if available. listTemplates :: HasLogFunc env => RIO env () @@ -295,7 +282,7 @@ resp <- catch (liftM Right $ httpLbs req) (\(ex :: HttpException) -> return . Left $ "Failed to download template info. The HTTP error was: " <> show ex) case resp >>= is200 of Left err -> do - logInfo $ T.pack err + logInfo $ fromString err return M.empty Right resp' -> case Yaml.decodeEither (LB.toStrict $ getResponseBody resp') :: Either String Object of @@ -421,7 +408,7 @@ show (InvalidTemplate name why) = "The template \"" <> T.unpack (templateName name) <> "\" is invalid and could not be used. " <> - "The error was: \"" <> why <> "\"" + "The error was: " <> why show (AttemptedOverwrites fps) = "The template would create the following files, but they already exist:\n" <> unlines (map ((" " ++) . toFilePath) fps) <> diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -15,12 +15,12 @@ import Stack.Prelude import qualified Data.Text as T import Data.Version (showVersion) +import Lens.Micro (set) import Path.IO import qualified Paths_stack as Meta import Stack.Config (getInNixShell, getInContainer) import Stack.Config.Nix (nixCompiler) import Stack.Constants (platformVariantEnvVar,inNixShellEnvVar,inContainerEnvVar) -import Stack.Exec (exec) import Stack.Types.Config import Stack.Types.Docker import Stack.Types.Nix @@ -28,7 +28,7 @@ import Stack.Types.Compiler import System.Environment (getArgs,getExecutablePath,lookupEnv) import qualified System.FilePath as F -import System.Process.Read (getEnvOverride) +import RIO.Process (processContextL, exec) -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. @@ -63,8 +63,9 @@ -> RIO env (String, [String]) -> RIO env () runShellAndExit mprojectRoot getCompilerVersion getCmdArgs = do - config <- view configL - envOverride <- getEnvOverride (configPlatform config) + config <- view configL + envOverride <- view processContextL + local (set processContextL envOverride) $ do (cmnd,args) <- fmap (escape *** map escape) getCmdArgs mshellFile <- traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $ @@ -73,7 +74,7 @@ inContainer <- getInContainer ghc <- either throwIO return $ nixCompiler compilerVersion let pkgsInConfig = nixPackages (configNix config) - pkgs = pkgsInConfig ++ [ghc, "git", "gcc"] + pkgs = pkgsInConfig ++ [ghc, "git", "gcc", "gmp"] pkgsStr = "[" <> T.intercalate " " pkgs <> "]" pureShell = nixPureShell (configNix config) addGCRoots = nixAddGCRoots (configNix config) @@ -113,12 +114,12 @@ -- Using --run instead of --command so we cannot -- end up in the nix-shell if stack build is Ctrl-C'd pathVar <- liftIO $ lookupEnv "PATH" - logDebug $ "PATH is: " <> T.pack (show pathVar) + logDebug $ "PATH is: " <> displayShow pathVar logDebug $ "Using a nix-shell environment " <> (case mshellFile of - Just path -> "from file: " <> T.pack (toFilePath path) - Nothing -> "with nix packages: " <> T.intercalate ", " pkgs) - exec envOverride "nix-shell" fullArgs + Just path -> "from file: " <> fromString (toFilePath path) + Nothing -> "with nix packages: " <> display (T.intercalate ", " pkgs)) + exec "nix-shell" fullArgs -- | Shell-escape quotes inside the string and enclose it in quotes. escape :: String -> String diff --git a/src/Stack/Options/BuildMonoidParser.hs b/src/Stack/Options/BuildMonoidParser.hs --- a/src/Stack/Options/BuildMonoidParser.hs +++ b/src/Stack/Options/BuildMonoidParser.hs @@ -14,12 +14,12 @@ buildOptsMonoidParser :: GlobalOptsContext -> Parser BuildOptsMonoid buildOptsMonoidParser hide0 = - BuildOptsMonoid <$> trace <*> profile <*> noStrip <*> + BuildOptsMonoid <$> trace' <*> profile <*> noStrip <*> libProfiling <*> exeProfiling <*> libStripping <*> exeStripping <*> haddock <*> haddockOptsParser hideBool <*> openHaddocks <*> haddockDeps <*> haddockInternal <*> haddockHyperlinkSource <*> copyBins <*> copyCompilerTool <*> - preFetch <*> keepGoing <*> forceDirty <*> + preFetch <*> keepGoing <*> keepTmpFiles <*> forceDirty <*> tests <*> testOptsParser hideBool <*> benches <*> benchOptsParser hideBool <*> reconfigure <*> cabalVerbose <*> splitObjs <*> skipComponents where @@ -31,7 +31,7 @@ -- These use 'Any' because they are not settable in stack.yaml, so -- there is no need for options like --no-profile. - trace = Any <$> + trace' = Any <$> flag False True @@ -119,6 +119,11 @@ firstBoolFlags "keep-going" "continue running after a step fails (default: false for build, true for test/bench)" + hide + keepTmpFiles = + firstBoolFlags + "keep-tmp-files" + "keep intermediate files and build directories (default: false)" hide preFetch = firstBoolFlags diff --git a/src/Stack/Options/Completion.hs b/src/Stack/Options/Completion.hs --- a/src/Stack/Options/Completion.hs +++ b/src/Stack/Options/Completion.hs @@ -12,7 +12,6 @@ import Data.Char (isSpace) import Data.List (isPrefixOf) -import Data.List.Extra (nubOrd) import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set @@ -28,7 +27,7 @@ import Stack.Setup import Stack.Types.Config import Stack.Types.FlagName -import Stack.Types.Package +import Stack.Types.NamedComponent import Stack.Types.PackageName import System.Process (readProcess) import Language.Haskell.TH.Syntax (runIO, lift) @@ -66,11 +65,12 @@ runRIO envConfig (inner input) targetCompleter :: Completer -targetCompleter = buildConfigCompleter $ \input -> do - lpvs <- fmap lpProject getLocalPackages - return $ - filter (input `isPrefixOf`) $ - concatMap allComponentNames (Map.toList lpvs) +targetCompleter = buildConfigCompleter $ \input -> + filter (input `isPrefixOf`) + . concatMap allComponentNames + . Map.toList + . lpProject + <$> getLocalPackages where allComponentNames (name, lpv) = map (T.unpack . renderPkgComponent . (name,)) (Set.toList (lpvComponents lpv)) @@ -103,10 +103,14 @@ _ -> normalFlags projectExeCompleter :: Completer -projectExeCompleter = buildConfigCompleter $ \input -> do - lpvs <- fmap lpProject getLocalPackages - return $ - filter (input `isPrefixOf`) $ - nubOrd $ - concatMap (\(_, lpv) -> map (C.unUnqualComponentName . fst) (C.condExecutables (lpvGPD lpv))) $ - Map.toList lpvs +projectExeCompleter = buildConfigCompleter $ \input -> + filter (input `isPrefixOf`) + . nubOrd + . concatMap + (\(_, lpv) -> map + (C.unUnqualComponentName . fst) + (C.condExecutables (lpvGPD lpv)) + ) + . Map.toList + . lpProject + <$> getLocalPackages diff --git a/src/Stack/Options/ConfigParser.hs b/src/Stack/Options/ConfigParser.hs --- a/src/Stack/Options/ConfigParser.hs +++ b/src/Stack/Options/ConfigParser.hs @@ -63,7 +63,7 @@ <*> nixOptsParser True <*> firstBoolFlags "system-ghc" - "using the system installed GHC (on the PATH) if available and a matching version. Disabled by default." + "using the system installed GHC (on the PATH) if it is available and its version matches. Disabled by default." hide <*> firstBoolFlags "install-ghc" diff --git a/src/Stack/Options/DockerParser.hs b/src/Stack/Options/DockerParser.hs --- a/src/Stack/Options/DockerParser.hs +++ b/src/Stack/Options/DockerParser.hs @@ -25,11 +25,11 @@ "using a Docker container. --docker implies 'system-ghc: true'" hide <*> fmap First - ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <> + (Just . DockerMonoidRepo <$> option str (long (dockerOptName dockerRepoArgName) <> hide <> metavar "NAME" <> help "Docker repository name") <|> - (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <> + Just . DockerMonoidImage <$> option str (long (dockerOptName dockerImageArgName) <> hide <> metavar "IMAGE" <> help "Exact Docker image ID (overrides docker-repo)") <|> diff --git a/src/Stack/Options/NixParser.hs b/src/Stack/Options/NixParser.hs --- a/src/Stack/Options/NixParser.hs +++ b/src/Stack/Options/NixParser.hs @@ -13,8 +13,7 @@ nixOptsParser :: Bool -> Parser NixOptsMonoid nixOptsParser hide0 = overrideActivation <$> (NixOptsMonoid - <$> pure (Any False) - <*> firstBoolFlags nixCmdName + <$> firstBoolFlags nixCmdName "use of a Nix-shell. Implies 'system-ghc: true'" hide <*> firstBoolFlags "nix-pure" diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -33,7 +33,6 @@ ,resolvePackageDescription ,packageDescTools ,packageDependencies - ,autogenDir ,cabalFilePackageId ,gpdPackageIdentifier ,gpdPackageName @@ -42,13 +41,12 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 -import Data.List (isSuffixOf, partition, isPrefixOf) -import Data.List.Extra (nubOrd) +import Data.List (isSuffixOf, isPrefixOf) +import Data.Maybe (maybe) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) +import Data.Text.Encoding (decodeUtf8) import Distribution.Compiler import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as Cabal @@ -56,9 +54,9 @@ import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import qualified Distribution.PackageDescription as D import Distribution.PackageDescription hiding (FlagName) -import Distribution.PackageDescription.Parse -import qualified Distribution.PackageDescription.Parse as D -import Distribution.ParseUtils +import Distribution.PackageDescription.Parsec +import qualified Distribution.PackageDescription.Parsec as D +import Distribution.Parsec.Common (PWarning (..), showPos) import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..)) import qualified Distribution.Text as D @@ -68,7 +66,6 @@ import qualified Distribution.Types.LegacyExeDependency as Cabal import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Verbosity as D -import Distribution.Version (showVersion) import Lens.Micro (lens) import qualified Hpack import qualified Hpack.Config as Hpack @@ -79,7 +76,9 @@ import Stack.Build.Installed import Stack.Constants import Stack.Constants.Config -import Stack.Prelude +import Stack.Fetch (loadFromIndex) +import Stack.PackageIndex (HasCabalLoader (..)) +import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint import Stack.Types.Build import Stack.Types.BuildPlan (ExeName (..)) @@ -87,6 +86,7 @@ import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName @@ -96,10 +96,10 @@ import System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error -import System.Process.Run (runCmd, Cmd(..)) +import RIO.Process data Ctx = Ctx { ctxFile :: !(Path Abs File) - , ctxDir :: !(Path Abs Dir) + , ctxDistDir :: !(Path Abs Dir) , ctxEnvConfig :: !EnvConfig } @@ -110,6 +110,10 @@ instance HasRunner Ctx where runnerL = configL.runnerL instance HasConfig Ctx +instance HasCabalLoader Ctx where + cabalLoaderL = configL.cabalLoaderL +instance HasProcessContext Ctx where + processContextL = configL.processContextL instance HasBuildConfig Ctx instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -122,14 +126,14 @@ -> BS.ByteString -> m ([PWarning], GenericPackageDescription) rawParseGPD key bs = - case parseGenericPackageDescription chars of - ParseFailed e -> throwM $ PackageInvalidCabalFile key e - ParseOk warnings gpkg -> return (warnings,gpkg) + case eres of + Left (mversion, errs) -> throwM $ PackageInvalidCabalFile key + (fromCabalVersion <$> mversion) + errs + warnings + Right gpkg -> return (warnings, gpkg) where - chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs)) - - -- https://github.com/haskell/hackage-server/issues/351 - dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs -- | Read the raw, unresolved package information from a file. readPackageUnresolvedDir @@ -154,14 +158,10 @@ ((m1, M.insert dir ret m2), ret) where toPretty :: String -> PWarning -> [Doc AnsiAnn] - toPretty src (PWarning x) = - [ flow "Cabal file warning in" - , fromString src <> ":" - , flow x - ] - toPretty src (UTFWarning ln msg) = + toPretty src (PWarning _type pos msg) = [ flow "Cabal file warning in" - , fromString src <> ":" <> fromString (show ln) <> ":" + , fromString src <> "@" + , fromString (showPos pos) <> ":" , flow msg ] @@ -187,17 +187,16 @@ -- | Read the 'GenericPackageDescription' from the given -- 'PackageIdentifierRevision'. readPackageUnresolvedIndex - :: forall env. HasRunner env - => (PackageIdentifierRevision -> IO ByteString) -- ^ load the raw bytes - -> PackageIdentifierRevision + :: forall env. HasCabalLoader env + => PackageIdentifierRevision -> RIO env GenericPackageDescription -readPackageUnresolvedIndex loadFromIndex pir@(PackageIdentifierRevision pi' _) = do +readPackageUnresolvedIndex pir@(PackageIdentifierRevision pi' _) = do ref <- view $ runnerL.to runnerParsedCabalFiles (m, _) <- readIORef ref case M.lookup pir m of Just gpd -> return gpd Nothing -> do - bs <- liftIO $ loadFromIndex pir + bs <- loadFromIndex pir (_warnings, gpd) <- rawParseGPD (Left pir) bs let foundPI = fromCabalPackageIdentifier @@ -260,7 +259,7 @@ Package { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) - , packageLicense = license pkg + , packageLicense = licenseRaw pkg , packageDeps = deps , packageFiles = pkgFiles , packageTools = packageDescTools pkg @@ -335,11 +334,11 @@ distDir <- distDirFromDir pkgDir env <- view envConfigL (componentModules,componentFiles,dataFiles',warnings) <- - runReaderT + runRIO + (Ctx cabalfp distDir env) (packageDescModulesAndFiles pkg) - (Ctx cabalfp (buildDir distDir) env) setupFiles <- - if buildType pkg `elem` [Nothing, Just Custom] + if buildType pkg == Custom then do let setupHsPath = pkgDir $(mkRelFile "Setup.hs") setupLhsPath = pkgDir $(mkRelFile "Setup.lhs") @@ -386,19 +385,13 @@ -> m (Map NamedComponent BuildInfoOpts) generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do config <- view configL + cabalVer <- view cabalVersionL distDir <- distDirFromDir cabalDir - let cabalMacros = autogenDir distDir $(mkRelFile "cabal_macros.h") - exists <- doesFileExist cabalMacros - let mcabalMacros = - if exists - then Just cabalMacros - else Nothing let generate namedComponent binfo = ( namedComponent , generateBuildInfoOpts BioInput { biSourceMap = sourceMap , biInstalledMap = installedMap - , biCabalMacros = mcabalMacros , biCabalDir = cabalDir , biDistDir = distDir , biOmitPackages = omitPkgs @@ -408,6 +401,7 @@ , biConfigLibDirs = configExtraLibDirs config , biConfigIncludeDirs = configExtraIncludeDirs config , biComponentName = namedComponent + , biCabalVersion = cabalVer } ) return @@ -442,7 +436,6 @@ data BioInput = BioInput { biSourceMap :: !SourceMap , biInstalledMap :: !InstalledMap - , biCabalMacros :: !(Maybe (Path Abs File)) , biCabalDir :: !(Path Abs Dir) , biDistDir :: !(Path Abs Dir) , biOmitPackages :: ![PackageName] @@ -452,6 +445,7 @@ , biConfigLibDirs :: !(Set FilePath) , biConfigIncludeDirs :: !(Set FilePath) , biComponentName :: !NamedComponent + , biCabalVersion :: !Version } -- | Generate GHC options for the target. Since Cabal also figures out @@ -471,7 +465,7 @@ , bioOneWordOpts = nubOrd $ concat [extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles] , bioPackageFlags = deps - , bioCabalMacros = biCabalMacros + , bioCabalMacros = componentAutogen $(mkRelFile "cabal_macros.h") } where cObjectFiles = @@ -501,14 +495,19 @@ isGhc _ = False extOpts = map (("-X" ++) . D.display) (usedExtensions biBuildInfo) srcOpts = - map - (("-i" <>) . toFilePathNoTrailingSep) - ([biCabalDir | null (hsSourceDirs biBuildInfo)] <> - mapMaybe toIncludeDir (hsSourceDirs biBuildInfo) <> - [autogenDir biDistDir,buildDir biDistDir] <> - [makeGenDir (buildDir biDistDir) - | Just makeGenDir <- [fileGenDirFromComponentName biComponentName]]) ++ - ["-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir)] + map (("-i" <>) . toFilePathNoTrailingSep) + (concat + [ [ componentBuildDir biCabalVersion biComponentName biDistDir ] + , [ biCabalDir + | null (hsSourceDirs biBuildInfo) + ] + , mapMaybe toIncludeDir (hsSourceDirs biBuildInfo) + , [ componentAutogen ] + , maybeToList (packageAutogenDir biCabalVersion biDistDir) + , [ componentOutputDir biComponentName biDistDir ] + ]) ++ + [ "-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir) ] + componentAutogen = componentAutogenDir biCabalVersion biComponentName biDistDir toIncludeDir "." = Just biCabalDir toIncludeDir relDir = concatAndColapseAbsDir biCabalDir relDir includeOpts = @@ -571,35 +570,55 @@ relCFilePath <- stripProperPrefix cabalDir cFilePath relOFilePath <- parseRelFile (replaceExtension (toFilePath relCFilePath) "o") - addComponentPrefix <- fileGenDirFromComponentName namedComponent - return (addComponentPrefix (buildDir distDir) relOFilePath) + return (componentOutputDir namedComponent distDir relOFilePath) +-- | Make the global autogen dir if Cabal version is new enough. +packageAutogenDir :: Version -> Path Abs Dir -> Maybe (Path Abs Dir) +packageAutogenDir cabalVer distDir + | cabalVer < $(mkVersion "2.0") = Nothing + | otherwise = Just $ buildDir distDir $(mkRelDir "global-autogen") + +-- | Make the autogen dir. +componentAutogenDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir +componentAutogenDir cabalVer component distDir = + componentBuildDir cabalVer component distDir $(mkRelDir "autogen") + +-- | See 'Distribution.Simple.LocalBuildInfo.componentBuildDir' +componentBuildDir :: Version -> NamedComponent -> Path Abs Dir -> Path Abs Dir +componentBuildDir cabalVer component distDir + | cabalVer < $(mkVersion "2.0") = buildDir distDir + | otherwise = + case component of + CLib -> buildDir distDir + CInternalLib name -> buildDir distDir componentNameToDir name + CExe name -> buildDir distDir componentNameToDir name + CTest name -> buildDir distDir componentNameToDir name + CBench name -> buildDir distDir componentNameToDir name + -- | The directory where generated files are put like .o or .hs (from .x files). -fileGenDirFromComponentName - :: MonadThrow m - => NamedComponent -> m (Path b Dir -> Path b Dir) -fileGenDirFromComponentName namedComponent = +componentOutputDir :: NamedComponent -> Path Abs Dir -> Path Abs Dir +componentOutputDir namedComponent distDir = case namedComponent of - CLib -> return id + CLib -> buildDir distDir + CInternalLib name -> makeTmp name CExe name -> makeTmp name CTest name -> makeTmp name CBench name -> makeTmp name - where makeTmp name = do - prefix <- parseRelDir (T.unpack name <> "/" <> T.unpack name <> "-tmp") - return ( prefix) - --- | Make the autogen dir. -autogenDir :: Path Abs Dir -> Path Abs Dir -autogenDir distDir = buildDir distDir $(mkRelDir "autogen") + where + makeTmp name = + buildDir distDir componentNameToDir (name <> "/" <> name <> "-tmp") --- | Make the build dir. +-- | Make the build dir. Note that Cabal >= 2.0 uses the +-- 'componentBuildDir' above for some things. buildDir :: Path Abs Dir -> Path Abs Dir buildDir distDir = distDir $(mkRelDir "build") --- | Make the component-specific subdirectory of the build directory. -getBuildComponentDir :: Maybe String -> Maybe (Path Rel Dir) -getBuildComponentDir Nothing = Nothing -getBuildComponentDir (Just name) = parseRelDir (name FilePath. (name ++ "-tmp")) +-- NOTE: don't export this, only use it for valid paths based on +-- component names. +componentNameToDir :: Text -> Path Rel Dir +componentNameToDir name = + fromMaybe (error "Invariant violated: component names should always parse as directory names") + (parseRelDir (T.unpack name)) -- | Get all dependencies of the package (buildable targets only). -- @@ -655,26 +674,41 @@ go2 :: Cabal.ExeDependency -> (ExeName, VersionRange) go2 (Cabal.ExeDependency _pkg name range) = (ExeName $ T.pack $ Cabal.unUnqualComponentName name, range) --- | Variant of 'allBuildInfo' from Cabal that includes foreign --- libraries; see +-- | Variant of 'allBuildInfo' from Cabal that, like versions before +-- 2.2, only includes buildable components. allBuildInfo' :: PackageDescription -> [BuildInfo] -allBuildInfo' pkg = allBuildInfo pkg ++ - [ bi | flib <- foreignLibs pkg - , let bi = foreignLibBuildInfo flib - , buildable bi - ] +allBuildInfo' pkg_descr = [ bi | lib <- allLibraries pkg_descr + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | flib <- foreignLibs pkg_descr + , let bi = foreignLibBuildInfo flib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi ] + ++ [ bi | tst <- benchmarks pkg_descr + , let bi = benchmarkBuildInfo tst + , buildable bi ] -- | Get all files referenced by the package. packageDescModulesAndFiles - :: (MonadLogger m, MonadUnliftIO m, MonadReader Ctx m, MonadThrow m) - => PackageDescription - -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) + :: PackageDescription + -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do (libraryMods,libDotCabalFiles,libWarnings) <- -- FIXME add in sub libraries maybe (return (M.empty, M.empty, [])) (asModuleAndFileMap libComponent libraryFiles) (library pkg) + (subLibrariesMods,subLibDotCabalFiles,subLibWarnings) <- + liftM + foldTuples + (mapM + (asModuleAndFileMap internalLibComponent libraryFiles) + (subLibraries pkg)) (executableMods,exeDotCabalFiles,exeWarnings) <- liftM foldTuples @@ -694,25 +728,25 @@ dfiles <- resolveGlobFiles (extraSrcFiles pkg ++ map (dataDir pkg FilePath.) (dataFiles pkg)) - let modules = libraryMods <> executableMods <> testMods <> benchModules + let modules = libraryMods <> subLibrariesMods <> executableMods <> testMods <> benchModules files = - libDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <> + libDotCabalFiles <> subLibDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <> benchDotCabalPaths - warnings = libWarnings <> exeWarnings <> testWarnings <> benchWarnings + warnings = libWarnings <> subLibWarnings <> exeWarnings <> testWarnings <> benchWarnings return (modules, files, dfiles, warnings) where libComponent = const CLib + internalLibComponent = CInternalLib . T.pack . maybe "" Cabal.unUnqualComponentName . libName exeComponent = CExe . T.pack . Cabal.unUnqualComponentName . exeName testComponent = CTest . T.pack . Cabal.unUnqualComponentName . testName benchComponent = CBench . T.pack . Cabal.unUnqualComponentName . benchmarkName asModuleAndFileMap label f lib = do - (a,b,c) <- f lib + (a,b,c) <- f (label lib) lib return (M.singleton (label lib) a, M.singleton (label lib) b, c) foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. -resolveGlobFiles :: (MonadLogger m,MonadUnliftIO m,MonadReader Ctx m) - => [String] -> m (Set (Path Abs File)) +resolveGlobFiles :: [String] -> RIO Ctx (Set (Path Abs File)) resolveGlobFiles = liftM (S.fromList . catMaybes . concat) . mapM resolve @@ -758,7 +792,7 @@ -- ["test/package-dump/ghc-7.8.txt","test/package-dump/ghc-7.10.txt"] -- @ -- -matchDirFileGlob_ :: (MonadLogger m, MonadIO m, HasRunner env, MonadReader env m) => String -> String -> m [String] +matchDirFileGlob_ :: HasRunner env => String -> String -> RIO env [String] matchDirFileGlob_ dir filepath = case parseFileGlob filepath of Nothing -> liftIO $ throwString $ "invalid file glob '" ++ filepath @@ -787,20 +821,13 @@ -- | Get all files referenced by the benchmark. benchmarkFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) -benchmarkFiles bench = do - dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . ctxFile) - (modules,files,warnings) <- - resolveFilesAndDeps - (Just $ Cabal.unUnqualComponentName $ benchmarkName bench) - (dirs ++ [dir]) - (bnames <> exposed) - haskellModuleExts - cfiles <- buildOtherSources build - return (modules, files <> cfiles, warnings) + :: NamedComponent + -> Benchmark + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) +benchmarkFiles component bench = do + resolveComponentFiles component build names where + names = bnames <> exposed exposed = case benchmarkInterface bench of BenchmarkExeV10 _ fp -> [DotCabalMain fp] @@ -810,21 +837,13 @@ -- | Get all files referenced by the test. testFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => TestSuite - -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) -testFiles test = do - dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . ctxFile) - (modules,files,warnings) <- - resolveFilesAndDeps - (Just $ Cabal.unUnqualComponentName $ testName test) - (dirs ++ [dir]) - (bnames <> exposed) - haskellModuleExts - cfiles <- buildOtherSources build - return (modules, files <> cfiles, warnings) + :: NamedComponent + -> TestSuite + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) +testFiles component test = do + resolveComponentFiles component build names where + names = bnames <> exposed exposed = case testInterface test of TestSuiteExeV10 _ fp -> [DotCabalMain fp] @@ -835,48 +854,50 @@ -- | Get all files referenced by the executable. executableFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Executable - -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) -executableFiles exe = do - dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . ctxFile) - (modules,files,warnings) <- - resolveFilesAndDeps - (Just $ Cabal.unUnqualComponentName $ exeName exe) - (dirs ++ [dir]) - (map DotCabalModule (otherModules build) ++ - [DotCabalMain (modulePath exe)]) - haskellModuleExts - cfiles <- buildOtherSources build - return (modules, files <> cfiles, warnings) + :: NamedComponent + -> Executable + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) +executableFiles component exe = do + resolveComponentFiles component build names where build = buildInfo exe + names = + map DotCabalModule (otherModules build) ++ + [DotCabalMain (modulePath exe)] -- | Get all files referenced by the library. libraryFiles - :: (MonadLogger m, MonadIO m, MonadReader Ctx m, MonadThrow m) - => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) -libraryFiles lib = do + :: NamedComponent + -> Library + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) +libraryFiles component lib = do + resolveComponentFiles component build names + where + build = libBuildInfo lib + names = bnames ++ exposed + exposed = map DotCabalModule (exposedModules lib) + bnames = map DotCabalModule (otherModules build) + +-- | Get all files referenced by the component. +resolveComponentFiles + :: NamedComponent + -> BuildInfo + -> [DotCabalDescriptor] + -> RIO Ctx (Map ModuleName (Path Abs File), Set DotCabalPath, [PackageWarning]) +resolveComponentFiles component build names = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . ctxFile) (modules,files,warnings) <- resolveFilesAndDeps - Nothing + component (dirs ++ [dir]) names haskellModuleExts cfiles <- buildOtherSources build return (modules, files <> cfiles, warnings) - where - names = bnames ++ exposed - exposed = map DotCabalModule (exposedModules lib) - bnames = map DotCabalModule (otherModules build) - build = libBuildInfo lib -- | Get all C sources and extra source files in a build. -buildOtherSources :: (MonadLogger m,MonadIO m,MonadReader Ctx m) - => BuildInfo -> m (Set DotCabalPath) +buildOtherSources :: BuildInfo -> RIO Ctx (Set DotCabalPath) buildOtherSources build = do csources <- liftM (S.map DotCabalCFilePath . S.fromList) @@ -1015,7 +1036,7 @@ } -- | Resolve the condition tree for the library. -resolveConditions :: (Monoid target,Show target) +resolveConditions :: (Semigroup target,Monoid target,Show target) => ResolveConditions -> (target -> cs -> target) -> CondTree ConfVar cs target @@ -1067,24 +1088,22 @@ -- extensions, plus find any of their module and TemplateHaskell -- dependencies. resolveFilesAndDeps - :: (MonadIO m, MonadLogger m, MonadReader Ctx m, MonadThrow m) - => Maybe String -- ^ Package component name + :: NamedComponent -- ^ Package component name -> [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. - -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) + -> RIO Ctx (Map ModuleName (Path Abs File),Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do (dotCabalPaths, foundModules, missingModules) <- loop names0 S.empty warnings <- liftM2 (++) (warnUnlisted foundModules) (warnMissing missingModules) return (foundModules, dotCabalPaths, warnings) where - loop [] _ = return (S.empty, S.empty, []) + loop [] _ = return (S.empty, M.empty, []) loop names doneModules0 = do resolved <- resolveFiles dirs names exts let foundFiles = mapMaybe snd resolved - (foundModules', missingModules') = partition (isJust . snd) resolved - foundModules = mapMaybe (dotCabalModule . fst) foundModules' - missingModules = mapMaybe (dotCabalModule . fst) missingModules' + foundModules = mapMaybe toResolvedModule resolved + missingModules = mapMaybe toMissingModule resolved pairs <- mapM (getDependencies component) foundFiles let doneModules = S.union @@ -1102,20 +1121,20 @@ (S.fromList (foundFiles <> map DotCabalFilePath thDepFiles)) resolvedFiles - , S.union - (S.fromList foundModules) + , M.union + (M.fromList foundModules) resolvedModules , missingModules) warnUnlisted foundModules = do let unlistedModules = - foundModules `S.difference` - S.fromList (mapMaybe dotCabalModule names0) + foundModules `M.difference` + M.fromList (mapMaybe (fmap (, ()) . dotCabalModule) names0) return $ - if S.null unlistedModules + if M.null unlistedModules then [] else [ UnlistedModulesWarning component - (S.toList unlistedModules)] + (map fst (M.toList unlistedModules))] warnMissing _missingModules = do return [] -- TODO: bring this back - see @@ -1130,12 +1149,26 @@ component missingModules] -} - + -- TODO: In usages of toResolvedModule / toMissingModule, some sort + -- of map + partition would probably be better. + toResolvedModule + :: (DotCabalDescriptor, Maybe DotCabalPath) + -> Maybe (ModuleName, Path Abs File) + toResolvedModule (DotCabalModule mn, Just (DotCabalModulePath fp)) = + Just (mn, fp) + toResolvedModule _ = + Nothing + toMissingModule + :: (DotCabalDescriptor, Maybe DotCabalPath) + -> Maybe ModuleName + toMissingModule (DotCabalModule mn, Nothing) = + Just mn + toMissingModule _ = + Nothing -- | Get the dependencies of a Haskell module file. getDependencies - :: (MonadReader Ctx m, MonadIO m, MonadLogger m) - => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File]) + :: NamedComponent -> DotCabalPath -> RIO Ctx (Set ModuleName, [Path Abs File]) getDependencies component dotCabalPath = case dotCabalPath of DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile @@ -1144,7 +1177,7 @@ DotCabalCFilePath{} -> return (S.empty, []) where readResolvedHi resolvedFile = do - dumpHIDir <- getDumpHIDir + dumpHIDir <- componentOutputDir component <$> asks ctxDistDir dir <- asks (parent . ctxFile) case stripProperPrefix dir resolvedFile of Nothing -> return (S.empty, []) @@ -1157,14 +1190,10 @@ if dumpHIExists then parseDumpHI dumpHIPath else return (S.empty, []) - getDumpHIDir = do - bld <- asks ctxDir - return $ maybe bld (bld ) (getBuildComponentDir component) -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI - :: (MonadReader Ctx m, MonadIO m, MonadLogger m) - => FilePath -> m (Set ModuleName, [Path Abs File]) + :: FilePath -> RIO Ctx (Set ModuleName, [Path Abs File]) parseDumpHI dumpHIPath = do dir <- asks (parent . ctxFile) dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath) @@ -1201,22 +1230,20 @@ -- looking for unique instances of base names applied with the given -- extensions. resolveFiles - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) - => [Path Abs Dir] -- ^ Directories to look in. + :: [Path Abs Dir] -- ^ Directories to look in. -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extensions. - -> m [(DotCabalDescriptor, Maybe DotCabalPath)] + -> RIO Ctx [(DotCabalDescriptor, Maybe DotCabalPath)] resolveFiles dirs names exts = forM names (\name -> liftM (name, ) (findCandidate dirs exts name)) -- | Find a candidate for the given module-or-filename from the list -- of directories and given extensions. findCandidate - :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader Ctx m) - => [Path Abs Dir] + :: [Path Abs Dir] -> [Text] -> DotCabalDescriptor - -> m (Maybe DotCabalPath) + -> RIO Ctx (Maybe DotCabalPath) findCandidate dirs exts name = do pkg <- asks ctxFile >>= parsePackageNameFromFilePath candidates <- liftIO makeNameCandidates @@ -1267,8 +1294,7 @@ -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. warnMultiple - :: (MonadLogger m, HasRunner env, MonadReader env m) - => DotCabalDescriptor -> Path b t -> [Path b t] -> m () + :: DotCabalDescriptor -> Path b t -> [Path b t] -> RIO Ctx () warnMultiple name candidate rest = -- TODO: figure out how to style 'name' and the dispOne stuff prettyWarnL @@ -1292,9 +1318,8 @@ -- For example: .erb for a Ruby file might exist in one of the -- directories. logPossibilities - :: (MonadIO m, MonadThrow m, MonadLogger m, HasRunner env, - MonadReader env m) - => [Path Abs Dir] -> ModuleName -> m () + :: HasRunner env + => [Path Abs Dir] -> ModuleName -> RIO env () logPossibilities dirs mn = do possibilities <- liftM concat (makePossibilities mn) unless (null possibilities) $ prettyWarnL @@ -1328,18 +1353,17 @@ -- If the directory contains a file named package.yaml, hpack is used to -- generate a .cabal file from it. findOrGenerateCabalFile - :: forall m env. - (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) + :: forall env. HasConfig env => Path Abs Dir -- ^ package directory - -> m (Path Abs File) + -> RIO env (Path Abs File) findOrGenerateCabalFile pkgDir = do hpack pkgDir findCabalFile where - findCabalFile :: m (Path Abs File) + findCabalFile :: RIO env (Path Abs File) findCabalFile = findCabalFile' >>= either throwIO return - findCabalFile' :: m (Either PackageException (Path Abs File)) + findCabalFile' :: RIO env (Either PackageException (Path Abs File)) findCabalFile' = do files <- liftIO $ findFiles pkgDir @@ -1358,8 +1382,7 @@ where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Generate .cabal file from package.yaml, if necessary. -hpack :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, HasConfig env, MonadReader env m) - => Path Abs Dir -> m () +hpack :: HasConfig env => Path Abs Dir -> RIO env () hpack pkgDir = do let hpackFile = pkgDir $(mkRelFile Hpack.packageConfig) exists <- liftIO $ doesFileExist hpackFile @@ -1389,16 +1412,17 @@ , flow "please upgrade and try again." ] Hpack.ExistingCabalFileWasModifiedManually -> prettyWarnL - [ flow "WARNING: " - , cabalFile - , flow " was modified manually. Ignoring package.yaml in favor of cabal file." - , flow "If you want to use package.yaml instead of the cabal file, " + [ cabalFile + , flow "was modified manually. Ignoring" + , display hpackFile + , flow "in favor of the cabal file. If you want to use the" + , display . filename $ hpackFile + , flow "file instead of the cabal file," , flow "then please delete the cabal file." ] - HpackCommand command -> do - envOverride <- getMinimalEnvOverride - let cmd = Cmd (Just pkgDir) command envOverride [] - runCmd cmd Nothing + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) @@ -1412,11 +1436,10 @@ return $ stack $(mkRelDir "logs") fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn -resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader Ctx m) - => Text - -> (Path Abs Dir -> String -> m (Maybe a)) +resolveOrWarn :: Text + -> (Path Abs Dir -> String -> RIO Ctx (Maybe a)) -> FilePath.FilePath - -> m (Maybe a) + -> RIO Ctx (Maybe a) resolveOrWarn subject resolver path = do cwd <- liftIO getCurrentDir file <- asks ctxFile @@ -1434,17 +1457,15 @@ -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). -resolveFileOrWarn :: (MonadIO m,MonadLogger m,MonadReader Ctx m) - => FilePath.FilePath - -> m (Maybe (Path Abs File)) +resolveFileOrWarn :: FilePath.FilePath + -> RIO Ctx (Maybe (Path Abs File)) resolveFileOrWarn = resolveOrWarn "File" f 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 :: (MonadIO m,MonadLogger m,MonadReader Ctx m) - => FilePath.FilePath - -> m (Maybe (Path Abs Dir)) +resolveDirOrWarn :: FilePath.FilePath + -> RIO Ctx (Maybe (Path Abs Dir)) resolveDirOrWarn = resolveOrWarn "Directory" f where f p x = liftIO (forgivingAbsence (resolveDir p x)) >>= rejectMissingDir @@ -1459,5 +1480,5 @@ where toStackPI (D.PackageIdentifier (D.unPackageName -> name) ver) = do name' <- parsePackageNameFromString name - ver' <- parseVersionFromString (showVersion ver) + let ver' = fromCabalVersion ver return (PackageIdentifier name' ver') diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -48,43 +48,41 @@ import Stack.Types.PackageName import Stack.Types.Version import System.Directory (getDirectoryContents, doesFileExist) -import System.Process.Read +import System.Process (readProcess) -- FIXME confirm that this is correct +import RIO.Process hiding (readProcess) -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump - :: (MonadUnliftIO m, MonadLogger m) - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a + -> ConduitM Text Void (RIO env) a + -> RIO env a ghcPkgDump = ghcPkgCmdArgs ["dump"] -- | Call ghc-pkg describe with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDescribe - :: (MonadUnliftIO m, MonadLogger m) + :: (HasProcessContext env, HasLogFunc env) => PackageName - -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a + -> ConduitM Text Void (RIO env) a + -> RIO env a ghcPkgDescribe pkgName = ghcPkgCmdArgs ["describe", "--simple-output", packageNameString pkgName] -- | Call ghc-pkg and stream to the given @Sink@, for a single database ghcPkgCmdArgs - :: (MonadUnliftIO m, MonadLogger m) + :: (HasProcessContext env, HasLogFunc env) => [String] - -> EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ if empty, use global - -> Sink Text IO a - -> m a -ghcPkgCmdArgs cmd menv wc mpkgDbs sink = do + -> ConduitM Text Void (RIO env) a + -> RIO env a +ghcPkgCmdArgs cmd wc mpkgDbs sink = do case reverse mpkgDbs of - (pkgDb:_) -> createDatabase menv wc pkgDb -- TODO maybe use some retry logic instead? + (pkgDb:_) -> createDatabase wc pkgDb -- TODO maybe use some retry logic instead? _ -> return () - sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink' + sinkProcessStdout (ghcPkgExeName wc) args sink' where args = concat [ case mpkgDbs of @@ -94,7 +92,7 @@ , cmd , ["--expand-pkgroot"] ] - sink' = CT.decodeUtf8 =$= sink + sink' = CT.decodeUtf8 .| sink -- | Create a new, empty @InstalledCache@ newInstalledCache :: MonadIO m => m InstalledCache @@ -102,14 +100,13 @@ -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: (MonadLogger m, MonadUnliftIO m) - => Path Abs File -> m InstalledCache +loadInstalledCache :: HasLogFunc env => Path Abs File -> RIO env InstalledCache loadInstalledCache path = do m <- $(versionedDecodeOrLoad installedCacheVC) path (return $ InstalledCacheInner Map.empty) liftIO $ InstalledCache <$> newIORef m -- | Save a @InstalledCache@ to disk -saveInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> InstalledCache -> m () +saveInstalledCache :: HasLogFunc env => Path Abs File -> InstalledCache -> RIO env () saveInstalledCache path (InstalledCache ref) = liftIO (readIORef ref) >>= $(versionedEncodeFile installedCacheVC) path @@ -160,22 +157,26 @@ -> Bool -- ^ require haddock? -> Bool -- ^ require debugging symbols? -> Map PackageName Version -- ^ allowed versions - -> Consumer (DumpPackage Bool Bool Bool) + -> ConduitM (DumpPackage Bool Bool Bool) o m (Map PackageName (DumpPackage Bool Bool Bool)) -sinkMatching reqProfiling reqHaddock reqSymbols allowed = do - dps <- CL.filter (\dp -> isAllowed (dpPackageIdent dp) && - (not reqProfiling || dpProfiling dp) && - (not reqHaddock || dpHaddock dp) && - (not reqSymbols || dpSymbols dp)) - =$= CL.consume - return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps +sinkMatching reqProfiling reqHaddock reqSymbols allowed = + Map.fromList + . map (packageIdentifierName . dpPackageIdent &&& id) + . Map.elems + . pruneDeps id dpGhcPkgId dpDepends const -- Could consider a better comparison in the future - dps + <$> (CL.filter predicate .| CL.consume) where + predicate dp = + isAllowed (dpPackageIdent dp) && + (not reqProfiling || dpProfiling dp) && + (not reqHaddock || dpHaddock dp) && + (not reqSymbols || dpSymbols dp) + isAllowed (PackageIdentifier name version) = case Map.lookup name allowed of Just version' | version /= version' -> False @@ -184,7 +185,7 @@ -- | Add profiling information to the stream of @DumpPackage@s addProfiling :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage Bool b c) + -> ConduitM (DumpPackage a b c) (DumpPackage Bool b c) m () addProfiling (InstalledCache ref) = CL.mapM go where @@ -219,7 +220,7 @@ -- | Add haddock information to the stream of @DumpPackage@s addHaddock :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage a Bool c) + -> ConduitM (DumpPackage a b c) (DumpPackage a Bool c) m () addHaddock (InstalledCache ref) = CL.mapM go where @@ -242,7 +243,7 @@ -- | Add debugging symbol information to the stream of @DumpPackage@s addSymbols :: MonadIO m => InstalledCache - -> Conduit (DumpPackage a b c) m (DumpPackage a b Bool) + -> ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m () addSymbols (InstalledCache ref) = CL.mapM go where @@ -281,6 +282,7 @@ data DumpPackage profiling haddock symbols = DumpPackage { dpGhcPkgId :: !GhcPkgId , dpPackageIdent :: !PackageIdentifier + , dpParentLibIdent :: !(Maybe PackageIdentifier) , dpLicense :: !(Maybe C.License) , dpLibDirs :: ![FilePath] , dpLibraries :: ![Text] @@ -313,9 +315,9 @@ -- | Convert a stream of bytes into a stream of @DumpPackage@s conduitDumpPackage :: MonadThrow m - => Conduit Text m (DumpPackage () () ()) -conduitDumpPackage = (=$= CL.catMaybes) $ eachSection $ do - pairs <- eachPair (\k -> (k, ) <$> CL.consume) =$= CL.consume + => ConduitM Text (DumpPackage () () ()) m () +conduitDumpPackage = (.| CL.catMaybes) $ eachSection $ do + pairs <- eachPair (\k -> (k, ) <$> CL.consume) .| CL.consume let m = Map.fromList pairs let parseS k = case Map.lookup k m of @@ -355,6 +357,11 @@ _ -> Nothing depends <- mapMaybeM parseDepend $ concatMap T.words $ parseM "depends" + -- Handle sublibs by recording the name of the parent library + -- If name of parent library is missing, this is not a sublib. + let mkParentLib n = PackageIdentifier n version + parentLib = mkParentLib <$> (parseS "package-name" >>= parsePackageName) + let parseQuoted key = case mapM (P.parseOnly (argsParser NoEscaping)) val of Left{} -> throwM (Couldn'tParseField key val) @@ -368,6 +375,7 @@ return $ Just DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = PackageIdentifier name version + , dpParentLibIdent = parentLib , dpLicense = license , dpLibDirs = libDirPaths , dpLibraries = T.words $ T.unwords libraries @@ -397,10 +405,10 @@ -- | Apply the given Sink to each section of output, broken by a single line containing --- eachSection :: Monad m - => Sink Line m a - -> Conduit Text m a + => ConduitM Line Void m a + -> ConduitM Text a m () eachSection inner = - CL.map (T.filter (/= '\r')) =$= CT.lines =$= start + CL.map (T.filter (/= '\r')) .| CT.lines .| start where peekText = await >>= maybe (return Nothing) (\bs -> @@ -411,22 +419,22 @@ start = peekText >>= maybe (return ()) (const go) go = do - x <- toConsumer $ takeWhileC (/= "---") =$= inner + x <- toConsumer $ takeWhileC (/= "---") .| inner yield x CL.drop 1 start -- | Grab each key/value pair eachPair :: Monad m - => (Text -> Sink Line m a) - -> Conduit Line m a + => (Text -> ConduitM Line Void m a) + -> ConduitM Line a m () eachPair inner = start where start = await >>= maybe (return ()) start' start' bs1 = - toConsumer (valSrc =$= inner key) >>= yield >> start + toConsumer (valSrc .| inner key) >>= yield >> start where (key, bs2) = T.break (== ':') bs1 (spaces, bs3) = T.span (== ' ') $ T.drop 1 bs2 @@ -461,7 +469,7 @@ (spaces, val) = T.splitAt i bs -- | General purpose utility -takeWhileC :: Monad m => (a -> Bool) -> Conduit a m a +takeWhileC :: Monad m => (a -> Bool) -> ConduitM a a m () takeWhileC f = loop where diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -24,13 +25,17 @@ , getPackageCaches , getPackageVersions , lookupPackageVersions + , CabalLoader (..) + , HasCabalLoader (..) + , configPackageIndex + , configPackageIndexRoot ) where import qualified Codec.Archive.Tar as Tar import Stack.Prelude import Data.Aeson.Extended +import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L -import Data.Conduit.Binary (sinkHandle, sourceHandle, sourceFile, sinkFile) import Data.Conduit.Zlib (ungzip) import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Strict as HashMap @@ -49,31 +54,30 @@ import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Download import Network.URI (parseURI) -import Path (toFilePath, parseAbsFile) +import Path (toFilePath, parseAbsFile, mkRelDir, mkRelFile, (), parseRelDir) import Path.Extra (tryGetModificationTime) import Path.IO -import Stack.Types.Config import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex import Stack.Types.PackageName +import Stack.Types.Runner (HasRunner) import Stack.Types.Version import qualified System.Directory as D import System.FilePath ((<.>)) -- | Populate the package index caches and return them. -populateCache :: HasConfig env => PackageIndex -> RIO env (PackageCache ()) +populateCache :: HasCabalLoader env => PackageIndex -> RIO env (PackageCache ()) populateCache index = do requireIndex index -- This uses full on lazy I/O instead of ResourceT to provide some -- protections. Caveat emptor path <- configPackageIndex (indexName index) - let loadPIS = withBinaryFile (Path.toFilePath path) ReadMode $ \h -> do + let loadPIS = withLazyFile (Path.toFilePath path) $ \lbs -> do logSticky "Populating index cache ..." - lbs <- liftIO $ L.hGetContents h loop 0 HashMap.empty (Tar.read lbs) pis0 <- loadPIS `catch` \e -> do logWarn $ "Exception encountered when parsing index tarball: " - <> T.pack (show (e :: Tar.FormatError)) + <> displayShow (e :: Tar.FormatError) logWarn "Automatically updating index and trying again" updateIndex index loadPIS @@ -224,27 +228,28 @@ ] -- | Require that an index be present, updating if it isn't. -requireIndex :: HasConfig env => PackageIndex -> RIO env () +requireIndex :: HasCabalLoader env => PackageIndex -> RIO env () requireIndex index = do tarFile <- configPackageIndex $ indexName index exists <- doesFileExist tarFile unless exists $ updateIndex index -- | Update all of the package indices -updateAllIndices :: HasConfig env => RIO env () +updateAllIndices :: HasCabalLoader env => RIO env () updateAllIndices = do clearPackageCaches - view packageIndicesL >>= mapM_ updateIndex + cl <- view cabalLoaderL + mapM_ updateIndex (clIndices cl) -- | Update the index tarball -updateIndex :: HasConfig env => PackageIndex -> RIO env () +updateIndex :: HasCabalLoader env => PackageIndex -> RIO env () updateIndex index = do let name = indexName index url = indexLocation index logSticky $ "Updating package index " - <> indexNameText (indexName index) + <> display (indexNameText (indexName index)) <> " (mirrored at " - <> url + <> display url <> ") ..." case indexType index of ITVanilla -> updateIndexHTTP name url @@ -257,16 +262,18 @@ oldTarFile <- configPackageIndexOld name oldCacheFile <- configPackageIndexCacheOld name liftIO $ ignoringAbsence (removeFile oldCacheFile) - liftIO $ runConduitRes $ sourceFile (toFilePath tarFile) .| sinkFile (toFilePath oldTarFile) + withSourceFile (toFilePath tarFile) $ \src -> + withSinkFile (toFilePath oldTarFile) $ \sink -> + runConduit $ src .| sink -- | Update the index tarball via HTTP -updateIndexHTTP :: HasConfig env +updateIndexHTTP :: HasCabalLoader env => IndexName -> Text -- ^ url -> RIO env () updateIndexHTTP indexName' url = do req <- parseRequest $ T.unpack url - logInfo ("Downloading package index from " <> url) + logInfo ("Downloading package index from " <> display url) gz <- configPackageIndexGz indexName' tar <- configPackageIndex indexName' wasDownloaded <- redownload req gz @@ -284,16 +291,14 @@ deleteCache indexName' liftIO $ do - withBinaryFile (toFilePath gz) ReadMode $ \input -> - withBinaryFile tmp WriteMode $ \output -> runConduit - $ sourceHandle input - .| ungzip - .| sinkHandle output + withSourceFile (toFilePath gz) $ \input -> + withSinkFile tmp $ \output -> -- FIXME use withSinkFileCautious + runConduit $ input .| ungzip .| output renameFile tmpPath tar -- | Update the index tarball via Hackage Security updateIndexHackageSecurity - :: HasConfig env + :: HasCabalLoader env => IndexName -> Text -- ^ base URL -> HackageSecurity @@ -306,7 +311,7 @@ manager <- liftIO getGlobalManager root <- configPackageIndexRoot indexName' run <- askRunInIO - let logTUF = run . logInfo . T.pack . HS.pretty + let logTUF = run . logInfo . fromString . HS.pretty withRepo = HS.withRepository (HS.makeHttpLib manager) [baseURI] @@ -350,7 +355,7 @@ -- but exited before deleting the cache. -- -- See https://github.com/commercialhaskell/stack/issues/3033 -packageIndexNotUpdated :: HasConfig env => IndexName -> RIO env () +packageIndexNotUpdated :: HasCabalLoader env => IndexName -> RIO env () packageIndexNotUpdated indexName' = do mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName' mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName' @@ -364,19 +369,19 @@ _ -> logInfo "No updates to your package index were found" -- | Delete the package index cache -deleteCache :: HasConfig env => IndexName -> RIO env () +deleteCache :: HasCabalLoader env => IndexName -> RIO env () deleteCache indexName' = do fp <- configPackageIndexCache indexName' eres <- liftIO $ tryIO $ removeFile fp case eres of - Left e -> logDebug $ "Could not delete cache: " <> T.pack (show e) - Right () -> logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) + Left e -> logDebug $ "Could not delete cache: " <> displayShow e + Right () -> logDebug $ "Deleted index cache at " <> fromString (toFilePath fp) -- | Get the known versions for a given package from the package caches. -- -- See 'getPackageCaches' for performance notes. -getPackageVersions :: HasConfig env => PackageName -> RIO env (Set Version) -getPackageVersions pkgName = fmap (lookupPackageVersions pkgName) getPackageCaches +getPackageVersions :: HasCabalLoader env => PackageName -> RIO env (Set Version) +getPackageVersions pkgName = lookupPackageVersions pkgName <$> getPackageCaches lookupPackageVersions :: PackageName -> PackageCache index -> Set Version lookupPackageVersions pkgName (PackageCache m) = @@ -386,30 +391,100 @@ -- -- This has two levels of caching: in memory, and the on-disk cache. So, -- feel free to call this function multiple times. -getPackageCaches :: HasConfig env => RIO env (PackageCache PackageIndex) +getPackageCaches :: HasCabalLoader env => RIO env (PackageCache PackageIndex) getPackageCaches = do - config <- view configL - mcached <- liftIO $ readIORef (configPackageCache config) + cl <- view cabalLoaderL + mcached <- readIORef (clCache cl) case mcached of Just cached -> return cached Nothing -> do - result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do + result <- liftM mconcat $ forM (clIndices cl) $ \index -> do fp <- configPackageIndexCache (indexName index) PackageCache pis <- +#if MIN_VERSION_template_haskell(2,13,0) + $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "LLL6OCcimOqRm3r0JmsSlLHcaLE=" +#else $(versionedDecodeOrLoad (storeVersionConfig "pkg-v5" "A607WaDwhg5VVvZTxNgU9g52DO8=" +#endif :: VersionConfig (PackageCache ()))) fp (populateCache index) return $ PackageCache ((fmap.fmap) (\((), mpd, files) -> (index, mpd, files)) pis) - liftIO $ writeIORef (configPackageCache config) (Just result) + liftIO $ writeIORef (clCache cl) (Just result) return result -- | Clear the in-memory hackage index cache. This is needed when the -- hackage index is updated. -clearPackageCaches :: HasConfig env => RIO env () +clearPackageCaches :: HasCabalLoader env => RIO env () clearPackageCaches = do - cacheRef <- view $ configL.to configPackageCache - liftIO $ writeIORef cacheRef Nothing + cl <- view cabalLoaderL + writeIORef (clCache cl) Nothing + +class HasRunner env => HasCabalLoader env where + cabalLoaderL :: Lens' env CabalLoader + +data CabalLoader = CabalLoader + { clCache :: !(IORef (Maybe (PackageCache PackageIndex))) + , clIndices :: ![PackageIndex] + -- ^ Information on package indices. This is left biased, meaning that + -- packages in an earlier index will shadow those in a later index. + -- + -- Warning: if you override packages in an index vs what's available + -- upstream, you may correct your compiled snapshots, as different + -- projects may have different definitions of what pkg-ver means! This + -- feature is primarily intended for adding local packages, not + -- overriding. Overriding is better accomplished by adding to your + -- list of packages. + -- + -- Note that indices specified in a later config file will override + -- previous indices, /not/ extend them. + -- + -- Using an assoc list instead of a Map to keep track of priority + , clStackRoot :: !(Path Abs Dir) + -- ^ ~/.stack more often than not + , clUpdateRef :: !(MVar Bool) + -- ^ 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. Start at @True@. + -- + -- TODO: probably makes sense to move this concern into getPackageCaches + , clConnectionCount :: !Int + -- ^ How many concurrent connections are allowed when downloading + , clIgnoreRevisionMismatch :: !Bool + -- ^ Ignore a revision mismatch when loading up cabal files, + -- and fall back to the latest revision. See: + -- + } + +-- | Root for a specific package index +configPackageIndexRoot :: HasCabalLoader env => IndexName -> RIO env (Path Abs Dir) +configPackageIndexRoot (IndexName name) = do + cl <- view cabalLoaderL + let root = clStackRoot cl + dir <- parseRelDir $ B8.unpack name + return (root $(mkRelDir "indices") dir) + +-- | Location of the 01-index.tar file +configPackageIndex :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndex name = ( $(mkRelFile "01-index.tar")) <$> configPackageIndexRoot name + +-- | Location of the 01-index.cache file +configPackageIndexCache :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexCache name = ( $(mkRelFile "01-index.cache")) <$> configPackageIndexRoot name + +-- | Location of the 00-index.cache file +configPackageIndexCacheOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot + +-- | Location of the 00-index.tar file. This file is just a copy of +-- the 01-index.tar file, provided for tools which still look for the +-- 00-index.tar file. +configPackageIndexOld :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot + +-- | Location of the 01-index.tar.gz file +configPackageIndexGz :: HasCabalLoader env => IndexName -> RIO env (Path Abs File) +configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot --------------- Lifted from cabal-install, Distribution.Client.Tar: -- | Return the number of blocks in an entry. diff --git a/src/Stack/PackageLocation.hs b/src/Stack/PackageLocation.hs --- a/src/Stack/PackageLocation.hs +++ b/src/Stack/PackageLocation.hs @@ -25,7 +25,6 @@ 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 qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Distribution.PackageDescription (GenericPackageDescription) @@ -39,8 +38,7 @@ import Stack.Types.Config import Stack.Types.PackageIdentifier import qualified System.Directory as Dir -import System.Process.Read -import System.Process.Run +import RIO.Process -- | Same as 'resolveMultiPackageLocation', but works on a -- 'SinglePackageLocation'. @@ -109,31 +107,30 @@ let fp = toFilePath file - withBinaryFile fp ReadMode $ \h -> do + withLazyFile fp $ \lbs -> do -- Share a single file read among all of the different -- parsing attempts. We're not worried about unbounded -- memory usage, as we will detect almost immediately if -- this is the wrong type of file. - lbs <- liftIO $ L.hGetContents h let tryTargz = do - logDebug $ "Trying to ungzip/untar " <> T.pack fp + logDebug $ "Trying to ungzip/untar " <> fromString fp let entries = Tar.read $ GZip.decompress lbs liftIO $ Tar.unpack (toFilePath dirTmp) entries tryZip = do - logDebug $ "Trying to unzip " <> T.pack fp + logDebug $ "Trying to unzip " <> fromString fp let archive = Zip.toArchive lbs liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination (toFilePath dirTmp)] archive tryTar = do - logDebug $ "Trying to untar (no ungzip) " <> T.pack fp + logDebug $ "Trying to untar (no ungzip) " <> fromString fp let entries = Tar.read lbs liftIO $ Tar.unpack (toFilePath dirTmp) entries err = throwM $ UnableToExtractArchive url file catchAnyLog goodpath handler = catchAny goodpath $ \e -> do - logDebug $ "Got exception: " <> T.pack (show e) + logDebug $ "Got exception: " <> displayShow e handler tryTargz `catchAnyLog` tryZip `catchAnyLog` tryTar `catchAnyLog` err @@ -204,31 +201,29 @@ exists <- doesDirExist dir unless exists $ do liftIO $ ignoringAbsence (removeDirRecur dir) - menv <- getMinimalEnvOverride - let cloneAndExtract commandName cloneArgs resetCommand = do + let cloneAndExtract commandName cloneArgs resetCommand = + withWorkingDir (toFilePath root) $ do ensureDir root - logInfo $ "Cloning " <> commit <> " from " <> url - callProcessInheritStderrStdout Cmd - { cmdDirectoryToRunIn = Just root - , cmdCommandToRun = commandName - , cmdEnvOverride = menv - , cmdCommandLineArguments = - "clone" : + logInfo $ "Cloning " <> display commit <> " from " <> display url + proc commandName + ("clone" : cloneArgs ++ [ T.unpack url , toFilePathNoTrailingSep dir - ] - } + ]) runProcess_ created <- doesDirExist dir unless created $ throwM $ FailedToCloneRepo commandName - readProcessNull (Just dir) menv commandName + withWorkingDir (toFilePath dir) $ readProcessNull commandName (resetCommand ++ [T.unpack commit, "--"]) - `catch` \case - ex@ProcessFailed{} -> do - logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url + `catchAny` \case + ex -> do + logInfo $ + "Please ensure that commit " <> + display commit <> + " exists within " <> + display url throwM ex - ex -> throwM ex case repoType' of RepoGit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] @@ -241,15 +236,14 @@ parseSingleCabalFileIndex :: forall env. HasConfig env - => (PackageIdentifierRevision -> IO ByteString) -- ^ lookup in index - -> Path Abs Dir -- ^ project root, used for checking out necessary files + => Path Abs Dir -- ^ project root, used for checking out necessary files -> PackageLocationIndex FilePath -> RIO env GenericPackageDescription -- 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). -parseSingleCabalFileIndex loadFromIndex _ (PLIndex pir) = readPackageUnresolvedIndex loadFromIndex pir -parseSingleCabalFileIndex _ root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc +parseSingleCabalFileIndex _ (PLIndex pir) = readPackageUnresolvedIndex pir +parseSingleCabalFileIndex root (PLOther loc) = lpvGPD <$> parseSingleCabalFile root False loc parseSingleCabalFile :: forall env. HasConfig env @@ -286,13 +280,12 @@ -- | 'parseMultiCabalFiles' but supports 'PLIndex' parseMultiCabalFilesIndex :: forall env. HasConfig env - => (PackageIdentifierRevision -> IO ByteString) - -> Path Abs Dir -- ^ project root, used for checking out necessary files + => Path Abs Dir -- ^ project root, used for checking out necessary files -> PackageLocationIndex Subdirs -> RIO env [(GenericPackageDescription, PackageLocationIndex FilePath)] -parseMultiCabalFilesIndex loadFromIndex _root (PLIndex pir) = - (pure . (, PLIndex pir)) <$> - readPackageUnresolvedIndex loadFromIndex pir -parseMultiCabalFilesIndex _ root (PLOther loc0) = +parseMultiCabalFilesIndex _root (PLIndex pir) = + pure . (, PLIndex pir) <$> + readPackageUnresolvedIndex pir +parseMultiCabalFilesIndex root (PLOther loc0) = map (\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv)) <$> parseMultiCabalFiles root False loc0 diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -20,19 +20,19 @@ import Stack.Constants import Stack.Constants.Config import Stack.GhcPkg as GhcPkg +import Stack.PackageIndex (HasCabalLoader (..)) import Stack.Types.Config import Stack.Types.Runner import qualified System.FilePath as FP import System.IO (stderr) -import System.Process.Read (EnvOverride(eoPath)) +import RIO.Process (HasProcessContext (..), exeSearchPathL) -- | Print out useful path information in a human-readable format (and -- support others later). path - :: (MonadUnliftIO m, MonadReader env m, HasEnvConfig env, MonadThrow m, - MonadLogger m) + :: HasEnvConfig env => [Text] - -> m () + -> RIO env () path keys = do -- We must use a BuildConfig from an EnvConfig to ensure that it contains the -- full environment info including GHC paths etc. @@ -42,12 +42,11 @@ -- global GHC. -- It was set up in 'withBuildConfigAndLock -> withBuildConfigExt -> setupEnv'. -- So it's not the *minimal* override path. - menv <- getMinimalEnvOverride snap <- packageDatabaseDeps plocal <- packageDatabaseLocal extra <- packageDatabaseExtra whichCompiler <- view $ actualCompilerVersionL.whichCompilerL - global <- GhcPkg.getGlobalDB menv whichCompiler + global <- GhcPkg.getGlobalDB whichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal toolsDir <- bindirCompilerTools @@ -78,7 +77,6 @@ path' (PathInfo bc - menv snap plocal global @@ -103,7 +101,6 @@ -- | Passed to all the path printers as a source of info. data PathInfo = PathInfo { piBuildConfig :: BuildConfig - , piEnvOverride :: EnvOverride , piSnapDb :: Path Abs Dir , piLocalDb :: Path Abs Dir , piGlobalDb :: Path Abs Dir @@ -122,6 +119,10 @@ instance HasRunner PathInfo where runnerL = configL.runnerL instance HasConfig PathInfo +instance HasCabalLoader PathInfo where + cabalLoaderL = configL.cabalLoaderL +instance HasProcessContext PathInfo where + processContextL = configL.processContextL instance HasBuildConfig PathInfo where buildConfigL = lens piBuildConfig (\x y -> x { piBuildConfig = y }) . buildConfigL @@ -148,7 +149,7 @@ , view $ stackYamlL.to toFilePath.to T.pack) , ( "PATH environment variable" , "bin-path" - , T.pack . intercalate [FP.searchPathSeparator] . eoPath . piEnvOverride ) + , T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL) , ( "Install location for GHC and other core tools" , "programs" , view $ configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack) diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs --- a/src/Stack/Prelude.hs +++ b/src/Stack/Prelude.hs @@ -1,216 +1,153 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stack.Prelude - ( mapLeft - , ResourceT - , runConduitRes - , runResourceT - , liftResourceT - , NoLogging (..) + ( withSourceFile + , withSinkFile + , withSinkFileCautious , withSystemTempDir - , fromFirst - , mapMaybeA - , mapMaybeM - , forMaybeA - , forMaybeM + , withKeepSystemTempDir + , sinkProcessStderrStdout + , sinkProcessStdout + , logProcessStderrStdout + , readProcessNull + , withProcessContext , stripCR - , logSticky - , logStickyDone - , RIO (..) - , runRIO - , HasLogFunc (..) , module X ) where -import Control.Applicative as X (Alternative, Applicative (..), - liftA, liftA2, liftA3, many, - optional, some, (<|>)) -import Control.Arrow as X (first, second, (&&&), (***)) -import Control.DeepSeq as X (NFData (..), force, ($!!)) -import Control.Monad as X (Monad (..), MonadPlus (..), filterM, - foldM, foldM_, forever, guard, join, - liftM, liftM2, replicateM_, unless, - when, zipWithM, zipWithM_, (<$!>), - (<=<), (=<<), (>=>)) -import Control.Monad.Catch as X (MonadThrow (..)) -import Control.Monad.Logger.CallStack - as X (Loc, LogLevel (..), LogSource, - LogStr, MonadLogger (..), - MonadLoggerIO (..), liftLoc, - logDebug, logError, logInfo, - logOther, logWarn, toLogStr) -import Control.Monad.Reader as X (MonadReader, MonadTrans (..), - ReaderT (..), ask, asks) -import Data.Bool as X (Bool (..), not, otherwise, (&&), - (||)) -import Data.ByteString as X (ByteString) -import Data.Char as X (Char) +import RIO as X import Data.Conduit as X (ConduitM, runConduit, (.|)) -import Data.Data as X (Data (..)) -import Data.Either as X (Either (..), either, isLeft, - isRight, lefts, partitionEithers, - rights) -import Data.Eq as X (Eq (..)) -import Data.Foldable as X (Foldable, all, and, any, asum, - concat, concatMap, elem, fold, - foldMap, foldl', foldr, forM_, for_, - length, mapM_, msum, notElem, null, - or, product, sequenceA_, sequence_, - sum, toList, traverse_) -import Data.Function as X (const, fix, flip, id, on, ($), (&), - (.)) -import Data.Functor as X (Functor (..), void, ($>), (<$), - (<$>)) -import Data.Hashable as X (Hashable) -import Data.HashMap.Strict as X (HashMap) -import Data.HashSet as X (HashSet) -import Data.Int as X -import Data.IntMap.Strict as X (IntMap) -import Data.IntSet as X (IntSet) -import Data.List as X (break, drop, dropWhile, filter, - lines, lookup, map, replicate, - reverse, span, take, takeWhile, - unlines, unwords, words, zip, (++)) -import Data.Map.Strict as X (Map) -import Data.Maybe as X (Maybe (..), catMaybes, fromMaybe, - isJust, isNothing, listToMaybe, - mapMaybe, maybe, maybeToList) -import Data.Monoid as X (All (..), Any (..), Endo (..), - First (..), Last (..), Monoid (..), - Product (..), Sum (..), (<>)) -import Data.Ord as X (Ord (..), Ordering (..), comparing) -import Data.Set as X (Set) -import Data.Store as X (Store) -import Data.String as X (IsString (..)) -import Data.Text as X (Text) -import Data.Traversable as X (Traversable (..), for, forM) -import Data.Vector as X (Vector) -import Data.Void as X (Void, absurd) -import Data.Word as X -import GHC.Generics as X (Generic) -import GHC.Stack as X (HasCallStack) -import Lens.Micro as X (Getting) -import Lens.Micro.Mtl as X (view) import Path as X (Abs, Dir, File, Path, Rel, toFilePath) -import Prelude as X (Bounded (..), Double, Enum, - FilePath, Float, Floating (..), - Fractional (..), IO, Integer, - Integral (..), Num (..), Rational, - Real (..), RealFloat (..), - RealFrac (..), Show, String, - asTypeOf, curry, error, even, - fromIntegral, fst, gcd, lcm, odd, - realToFrac, seq, show, snd, - subtract, uncurry, undefined, ($!), - (^), (^^)) -import Text.Read as X (Read, readMaybe) -import UnliftIO as X -import qualified Data.Text as T -import qualified Path.IO - -import qualified Control.Monad.Trans.Resource as Res (runResourceT, transResourceT) -import Control.Monad.Trans.Resource.Internal (ResourceT (ResourceT)) - -mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b -mapLeft f (Left a1) = Left (f a1) -mapLeft _ (Right b) = Right b - -fromFirst :: a -> First a -> a -fromFirst x = fromMaybe x . getFirst - --- | Applicative 'mapMaybe'. -mapMaybeA :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] -mapMaybeA f = fmap catMaybes . traverse f - --- | @'forMaybeA' '==' 'flip' 'mapMaybeA'@ -forMaybeA :: Applicative f => [a] -> (a -> f (Maybe b)) -> f [b] -forMaybeA = flip mapMaybeA +import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..)) --- | Monadic 'mapMaybe'. -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f = liftM catMaybes . mapM f +import qualified Path.IO --- | @'forMaybeM' '==' 'flip' 'mapMaybeM'@ -forMaybeM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] -forMaybeM = flip mapMaybeM +import qualified System.IO as IO +import qualified System.Directory as Dir +import qualified System.FilePath as FP +import System.IO.Error (isDoesNotExistError) --- | Strip trailing carriage return from Text -stripCR :: T.Text -> T.Text -stripCR t = fromMaybe t (T.stripSuffix "\r" t) +import Data.Conduit.Binary (sourceHandle, sinkHandle) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Process.Typed (withLoggedProcess_, createSource) +import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcess_, setStdout, setStderr, ProcessConfig, readProcessStdout_, workingDirL) +import Data.Store as X (Store) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) -runConduitRes :: MonadUnliftIO m => ConduitM () Void (ResourceT m) r -> m r -runConduitRes = runResourceT . runConduit +import qualified RIO.Text as T -runResourceT :: MonadUnliftIO m => ResourceT m a -> m a -runResourceT r = withRunInIO $ \run -> Res.runResourceT (Res.transResourceT run r) +-- | Get a source for a file. Unlike @sourceFile@, doesn't require +-- @ResourceT@. Unlike explicit @withBinaryFile@ and @sourceHandle@ +-- usage, you can't accidentally use @WriteMode@ instead of +-- @ReadMode@. +withSourceFile :: MonadUnliftIO m => FilePath -> (ConduitM i ByteString m () -> m a) -> m a +withSourceFile fp inner = withBinaryFile fp ReadMode $ inner . sourceHandle -liftResourceT :: MonadIO m => ResourceT IO a -> ResourceT m a -liftResourceT (ResourceT f) = ResourceT $ liftIO . f +-- | Same idea as 'withSourceFile', see comments there. +withSinkFile :: MonadUnliftIO m => FilePath -> (ConduitM ByteString o m () -> m a) -> m a +withSinkFile fp inner = withBinaryFile fp WriteMode $ inner . sinkHandle --- | Avoid orphan messes -newtype NoLogging a = NoLogging { runNoLogging :: IO a } - deriving (Functor, Applicative, Monad, MonadIO) -instance MonadUnliftIO NoLogging where - askUnliftIO = NoLogging $ - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . runNoLogging)) -instance MonadLogger NoLogging where - monadLoggerLog _ _ _ _ = return () +-- | Like 'withSinkFile', but ensures that the file is atomically +-- moved after all contents are written. +withSinkFileCautious + :: MonadUnliftIO m + => FilePath + -> (ConduitM ByteString o m () -> m a) + -> m a +withSinkFileCautious fp inner = + withRunInIO $ \run -> bracket acquire cleanup $ \(tmpFP, h) -> + run (inner $ sinkHandle h) <* (IO.hClose h *> Dir.renameFile tmpFP fp) + where + acquire = IO.openBinaryTempFile (FP.takeDirectory fp) (FP.takeFileName fp FP.<.> "tmp") + cleanup (tmpFP, h) = do + IO.hClose h + Dir.removeFile tmpFP `catch` \e -> + if isDoesNotExistError e + then return () + else throwIO e -- | Path version withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner --- | Write a "sticky" line to the terminal. Any subsequent lines will --- overwrite this one, and that same line will be repeated below --- again. In other words, the line sticks at the bottom of the output --- forever. Running this function again will replace the sticky line --- with a new sticky line. When you want to get rid of the sticky --- line, run 'logStickyDone'. --- -logSticky :: MonadLogger m => Text -> m () -logSticky = - logOther (LevelOther "sticky") +-- | Like `withSystemTempDir`, but the temporary directory is not deleted. +withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a +withKeepSystemTempDir str inner = withRunInIO $ \run -> do + path <- Path.IO.getTempDir + dir <- Path.IO.createTempDir path str + run $ inner dir --- | This will print out the given message with a newline and disable --- any further stickiness of the line until a new call to 'logSticky' --- happens. +-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers. -- --- It might be better at some point to have a 'runSticky' function --- that encompasses the logSticky->logStickyDone pairing. -logStickyDone :: MonadLogger m => Text -> m () -logStickyDone = - logOther (LevelOther "sticky-done") +-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. +sinkProcessStderrStdout + :: forall e o env. (HasProcessContext env, HasLogFunc env) + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> ConduitM ByteString Void (RIO env) e -- ^ Sink for stderr + -> ConduitM ByteString Void (RIO env) o -- ^ Sink for stdout + -> RIO env (e,o) +sinkProcessStderrStdout name args sinkStderr sinkStdout = + proc name args $ \pc0 -> do + let pc = setStdout createSource + $ setStderr createSource + pc0 + withProcess_ pc $ \p -> + runConduit (getStderr p .| sinkStderr) `concurrently` + runConduit (getStdout p .| sinkStdout) --- | The Reader+IO monad. This is different from a 'ReaderT' because: --- --- * It's not a transformer, it hardcodes IO for simpler usage and --- error messages. +-- | Consume the stdout of a process feeding strict 'ByteString's to a consumer. +-- If the process fails, spits out stdout and stderr as error log +-- level. Should not be used for long-running processes or ones with +-- lots of output; for that use 'sinkProcessStderrStdout'. -- --- * Instances of typeclasses like 'MonadLogger' are implemented using --- classes defined on the environment, instead of using an --- underlying monad. -newtype RIO env a = RIO { unRIO :: ReaderT env IO a } - deriving (Functor,Applicative,Monad,MonadIO,MonadReader env,MonadThrow) - -runRIO :: MonadIO m => env -> RIO env a -> m a -runRIO env (RIO (ReaderT f)) = liftIO (f env) +-- Throws a 'ReadProcessException' if unsuccessful. +sinkProcessStdout + :: (HasProcessContext env, HasLogFunc env) + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> ConduitM ByteString Void (RIO env) a -- ^ Sink for stdout + -> RIO env a +sinkProcessStdout name args sinkStdout = + proc name args $ \pc -> + withLoggedProcess_ (setStdin closed pc) $ \p -> runConcurrently + $ Concurrently (runConduit $ getStderr p .| CL.sinkNull) + *> Concurrently (runConduit $ getStdout p .| sinkStdout) -class HasLogFunc env where - logFuncL :: Getting r env (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) +logProcessStderrStdout + :: (HasCallStack, HasProcessContext env, HasLogFunc env) + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> RIO env () +logProcessStderrStdout pc = withLoggedProcess_ pc $ \p -> + let logLines = CB.lines .| CL.mapM_ (logInfo . displayBytesUtf8) + in runConcurrently + $ Concurrently (runConduit $ getStdout p .| logLines) + *> Concurrently (runConduit $ getStderr p .| logLines) -instance HasLogFunc env => MonadLogger (RIO env) where - monadLoggerLog a b c d = do - f <- view logFuncL - liftIO $ f a b c $ toLogStr d +-- | Read from the process, ignoring any output. +-- +-- Throws a 'ReadProcessException' exception if the process fails. +readProcessNull :: (HasProcessContext env, HasLogFunc env) + => String -- ^ Command + -> [String] -- ^ Command line arguments + -> RIO env () +readProcessNull name args = + -- We want the output to appear in any exceptions, so we capture and drop it + void $ proc name args readProcessStdout_ -instance HasLogFunc env => MonadLoggerIO (RIO env) where - askLoggerIO = view logFuncL +-- | Use the new 'ProcessContext', but retain the working directory +-- from the parent environment. +withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a +withProcessContext pcNew inner = do + pcOld <- view processContextL + let pcNew' = set workingDirL (view workingDirL pcOld) pcNew + local (set processContextL pcNew') inner -instance MonadUnliftIO (RIO env) where - askUnliftIO = RIO $ ReaderT $ \r -> - withUnliftIO $ \u -> - return (UnliftIO (unliftIO u . flip runReaderT r . unRIO)) +-- | Remove a trailing carriage return if present +stripCR :: Text -> Text +stripCR = T.dropSuffix "\r" diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -9,15 +9,16 @@ -- * Pretty printing functions displayPlain, displayWithColor -- * Logging based on pretty-print typeclass - , prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent - , prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL - , prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS + , prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent + , prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL + , prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS -- * Semantic styling functions -- | These are preferred to styling or colors directly, so that we can -- encourage consistency. , styleWarning, styleError, styleGood , styleShell, styleFile, styleUrl, styleDir, styleModule , styleCurrent, styleTarget + , styleRecommendation , displayMilliseconds -- * Formatting utils , bulletedList @@ -34,42 +35,46 @@ , indentAfterLabel, wordDocs, flow ) where -import Stack.Prelude +import qualified RIO +import Stack.Prelude hiding (Display (..)) import Data.List (intersperse) import qualified Data.Text as T -import Stack.Types.Config -import Stack.Types.Package +import qualified Distribution.ModuleName as C (ModuleName) +import qualified Distribution.Text as C (display) +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version -import qualified System.Clock as Clock import Text.PrettyPrint.Leijen.Extended displayWithColor :: (HasRunner env, Display a, HasAnsiAnn (Ann a), - MonadReader env m, MonadLogger m) + MonadReader env m, HasLogFunc env, HasCallStack) => a -> m T.Text displayWithColor x = do - useAnsi <- liftM logUseColor $ view logOptionsL - termWidth <- liftM logTermWidth $ view logOptionsL + useAnsi <- view useColorL + termWidth <- view $ runnerL.to runnerTermWidth return $ (if useAnsi then displayAnsi else displayPlain) termWidth x -- TODO: switch to using implicit callstacks once 7.8 support is dropped prettyWith :: (HasRunner env, HasCallStack, Display b, HasAnsiAnn (Ann b), - MonadReader env m, MonadLogger m) + MonadReader env m, MonadIO m) => LogLevel -> (a -> b) -> a -> m () -prettyWith level f = logOther level <=< displayWithColor . f +prettyWith level f = logGeneric "" level . RIO.display <=< displayWithColor . f -- Note: I think keeping this section aligned helps spot errors, might be -- worth keeping the alignment in place. -prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) +prettyDebugWith, prettyInfoWith, prettyNoteWith, prettyWarnWith, prettyErrorWith, prettyWarnNoIndentWith, prettyErrorNoIndentWith + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => (a -> Doc AnsiAnn) -> a -> m () prettyDebugWith = prettyWith LevelDebug prettyInfoWith = prettyWith LevelInfo +prettyNoteWith f = prettyWith LevelInfo + ((line <>) . (styleGood "Note:" <+>) . + indentAfterLabel . f) prettyWarnWith f = prettyWith LevelWarn ((line <>) . (styleWarning "Warning:" <+>) . indentAfterLabel . f) @@ -81,31 +86,34 @@ prettyErrorNoIndentWith f = prettyWith LevelWarn ((line <>) . (styleError "Error:" <+>) . f) -prettyDebug, prettyInfo, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) +prettyDebug, prettyInfo, prettyNote, prettyWarn, prettyError, prettyWarnNoIndent, prettyErrorNoIndent + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => Doc AnsiAnn -> m () prettyDebug = prettyDebugWith id prettyInfo = prettyInfoWith id +prettyNote = prettyNoteWith id prettyWarn = prettyWarnWith id prettyError = prettyErrorWith id prettyWarnNoIndent = prettyWarnNoIndentWith id prettyErrorNoIndent = prettyErrorNoIndentWith id -prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) +prettyDebugL, prettyInfoL, prettyNoteL, prettyWarnL, prettyErrorL, prettyWarnNoIndentL, prettyErrorNoIndentL + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => [Doc AnsiAnn] -> m () prettyDebugL = prettyDebugWith fillSep prettyInfoL = prettyInfoWith fillSep +prettyNoteL = prettyNoteWith fillSep prettyWarnL = prettyWarnWith fillSep prettyErrorL = prettyErrorWith fillSep prettyWarnNoIndentL = prettyWarnNoIndentWith fillSep prettyErrorNoIndentL = prettyErrorNoIndentWith fillSep -prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS - :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m) +prettyDebugS, prettyInfoS, prettyNoteS, prettyWarnS, prettyErrorS, prettyWarnNoIndentS, prettyErrorNoIndentS + :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m) => String -> m () prettyDebugS = prettyDebugWith flow prettyInfoS = prettyInfoWith flow +prettyNoteS = prettyNoteWith flow prettyWarnS = prettyWarnWith flow prettyErrorS = prettyErrorWith flow prettyWarnNoIndentS = prettyWarnNoIndentWith flow @@ -128,21 +136,21 @@ flow :: String -> Doc a flow = fillSep . wordDocs -debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m, +debugBracket :: (HasCallStack, HasRunner env, MonadReader env m, MonadIO m, MonadUnliftIO m) => Doc AnsiAnn -> m a -> m a debugBracket msg f = do - let output = logDebug <=< displayWithColor + let output = logDebug . RIO.display <=< displayWithColor output $ "Start: " <> msg - start <- liftIO $ Clock.getTime Clock.Monotonic + start <- getMonotonicTime x <- f `catch` \ex -> do - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end + end <- getMonotonicTime + let diff = end - start output $ "Finished with exception in" <+> displayMilliseconds diff <> ":" <+> msg <> line <> "Exception thrown: " <> fromString (show ex) throwIO (ex :: SomeException) - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end + end <- getMonotonicTime + let diff = end - start output $ "Finished in" <+> displayMilliseconds diff <> ":" <+> msg return x @@ -180,6 +188,10 @@ styleDir :: AnsiDoc -> AnsiDoc styleDir = bold . blue +-- | Style used to highlight part of a recommended course of action. +styleRecommendation :: AnsiDoc -> AnsiDoc +styleRecommendation = bold . green + -- | Style an 'AnsiDoc' in a way that emphasizes that it is related to -- a current thing. For example, could be used when talking about the -- current package we're processing when outputting the name of it. @@ -212,10 +224,13 @@ instance Display (PackageName, NamedComponent) where display = cyan . fromString . T.unpack . renderPkgComponent +instance Display C.ModuleName where + display = fromString . C.display + -- Display milliseconds. -displayMilliseconds :: Clock.TimeSpec -> AnsiDoc +displayMilliseconds :: Double -> AnsiDoc displayMilliseconds t = green $ - (fromString . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" + fromString (show (round (t * 1000) :: Int)) <> "ms" -- | Display a bulleted list of 'AnsiDoc'. bulletedList :: [AnsiDoc] -> AnsiDoc diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -14,6 +14,7 @@ , withBuildConfigAndLockNoDocker , withBuildConfig , withBuildConfigExt + , withBuildConfigDot , loadConfigWithOpts , loadCompilerVersion , withUserFileLock @@ -33,14 +34,14 @@ import System.Environment (getEnvironment) import System.IO import System.FileLock +import Stack.Dot -- FIXME it seems wrong that we call lcLoadBuildConfig multiple times loadCompilerVersion :: GlobalOpts -> LoadConfig -> IO (CompilerVersion 'CVWanted) -loadCompilerVersion go lc = do - bconfig <- lcLoadBuildConfig lc (globalCompiler go) - return $ view wantedCompilerVersionL bconfig +loadCompilerVersion go lc = + view wantedCompilerVersionL <$> lcLoadBuildConfig lc (globalCompiler go) -- | Enforce mutual exclusion of every action running via this -- function, on this path, on this users account. @@ -87,7 +88,7 @@ -> RIO Config () -> IO () withConfigAndLock go@GlobalOpts{..} inner = loadConfigWithOpts go $ \lc -> do - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> + withUserFileLock go (view stackRootL lc) $ \lk -> runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer (lcProjectRoot lc) @@ -108,7 +109,7 @@ globalConfigMonoid Nothing LCSNoProject - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> + withUserFileLock go (view stackRootL lc) $ \_lk -> runRIO (lcConfig lc) inner -- For now the non-locking version just unlocks immediately. @@ -155,7 +156,7 @@ -- installed on the host OS. -> IO () withBuildConfigExt skipDocker go@GlobalOpts{..} mbefore inner mafter = loadConfigWithOpts go $ \lc -> do - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk0 -> do + withUserFileLock go (view stackRootL lc) $ \lk0 -> do -- A local bit of state for communication between callbacks: curLk <- newIORef lk0 let inner' lk = @@ -205,9 +206,7 @@ -- If we have been relaunched in a Docker container, perform in-container initialization -- (switch UID, etc.). We do this after first loading the configuration since it must -- happen ASAP but needs a configuration. - case globalDockerEntrypoint of - Just de -> Docker.entrypoint (lcConfig lc) de - Nothing -> return () + forM_ globalDockerEntrypoint $ Docker.entrypoint (lcConfig lc) liftIO $ inner lc withRunnerGlobal :: GlobalOpts -> (Runner -> IO a) -> IO a @@ -226,7 +225,7 @@ withMiniConfigAndLock go@GlobalOpts{..} inner = withRunnerGlobal go $ \runner -> do miniConfig <- runRIO runner $ - (loadMiniConfig . lcConfig) <$> + loadMiniConfig . lcConfig <$> loadConfigMaybeProject globalConfigMonoid globalResolver @@ -237,3 +236,13 @@ munlockFile :: MonadIO m => Maybe FileLock -> m () munlockFile Nothing = return () munlockFile (Just lk) = liftIO $ unlockFile lk + +-- Plumbing for --test and --bench flags +withBuildConfigDot :: DotOpts -> GlobalOpts -> RIO EnvConfig () -> IO () +withBuildConfigDot opts go f = withBuildConfig go' f + where + go' = + (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $ + (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) + go + diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -17,8 +17,8 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative -import Control.Concurrent.Execute (ActionContext(..)) -import Stack.Prelude +import Control.Concurrent.Execute (ActionContext(..), Concurrency(..)) +import Stack.Prelude hiding (Display (..)) import Control.Monad.Reader.Class (local) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -26,7 +26,6 @@ import Data.Char (toLower) import Data.Data (cast) import Data.List -import Data.List.Extra (nubOrd) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -40,7 +39,7 @@ import Distribution.Package (Dependency (..)) import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Check as Check -import qualified Distribution.PackageDescription.Parse as Cabal +import qualified Distribution.PackageDescription.Parsec as Cabal import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Text as Cabal @@ -48,6 +47,7 @@ import Lens.Micro (set) import Path import Path.IO hiding (getModificationTime, getPermissions, withSystemTempDir) +import qualified RIO import Stack.Build (mkBaseConfigOpts, build) import Stack.Build.Execute import Stack.Build.Installed @@ -115,9 +115,9 @@ tweakCabal = pvpBounds /= PvpBoundsNone pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir - logInfo $ "Getting file list for " <> T.pack pkgFp + logInfo $ "Getting file list for " <> fromString pkgFp (fileList, cabalfp) <- getSDistFileList lp - logInfo $ "Building sdist tarball for " <> T.pack pkgFp + logInfo $ "Building sdist tarball for " <> fromString pkgFp files <- normalizeTarballPaths (map (T.unpack . stripCR . T.pack) (lines fileList)) -- We're going to loop below and eventually find the cabal @@ -173,8 +173,7 @@ unless (cabalfp == cabalfp') $ error $ "getCabalLbs: cabalfp /= cabalfp': " ++ show (cabalfp, cabalfp') (_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI - menv <- getMinimalEnvOverride - (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts + (installedMap, _, _, _) <- getInstalled GetInstalledOpts { getInstalledProfiling = False , getInstalledHaddock = False , getInstalledSymbols = False @@ -210,8 +209,13 @@ <+> display cabalfp , "" ] - case Cabal.parseGenericPackageDescription (showGenericPackageDescription gpd) of - Cabal.ParseOk _ roundtripped + (_warnings, eres) = Cabal.runParseResult + $ Cabal.parseGenericPackageDescription + $ T.encodeUtf8 + $ T.pack + $ showGenericPackageDescription gpd + case eres of + Right roundtripped | roundtripped == gpd -> return () | otherwise -> do prettyWarn $ vsep $ roundtripErrs ++ @@ -235,14 +239,14 @@ , flow "If the issue is not fixed, feel free to leave a comment on it indicating that you would like it to be fixed." , "" ] - Cabal.ParseFailed err -> do + Left (_version, errs) -> do prettyWarn $ vsep $ roundtripErrs ++ [ flow "In particular, parsing the rendered cabal file is yielding a parse error. Please check if there are already issues tracking this, and if not, please report new issues to the stack and cabal issue trackers, via" , bulletedList [ styleUrl "https://github.com/commercialhaskell/stack/issues/new" , styleUrl "https://github.com/haskell/cabal/issues/new" ] - , flow $ "The parse error is: " ++ show err + , flow $ "The parse error is: " ++ unlines (map show errs) , "" ] return @@ -319,23 +323,21 @@ getSDistFileList :: HasEnvConfig env => LocalPackage -> RIO env (String, Path Abs File) getSDistFileList lp = withSystemTempDir (stackProgName <> "-sdist") $ \tmpdir -> do - menv <- getMinimalEnvOverride let bopts = defaultBuildOpts let boptsCli = defaultBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli (locals, _) <- loadSourceMap NeedTargets boptsCli - run <- askRunInIO - withExecuteEnv menv bopts boptsCli baseConfigOpts locals + withExecuteEnv bopts boptsCli baseConfigOpts locals [] [] [] -- provide empty list of globals. This is a hack around custom Setup.hs files $ \ee -> - withSingleContext run ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do + withSingleContext ac ee task Nothing (Just "sdist") $ \_package cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = toFilePath tmpdir FP. "source-files-list" cabal KeepTHLoading ["sdist", "--list-sources", outFile] contents <- liftIO (S.readFile outFile) return (T.unpack $ T.decodeUtf8With T.lenientDecode contents, cabalfp) where package = lpPackage lp - ac = ActionContext Set.empty [] + ac = ActionContext Set.empty [] ConcurrencyAllowed task = Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package) , taskType = TTFiles lp Local @@ -355,9 +357,9 @@ -- TODO: consider whether erroring out is better - otherwise the -- user might upload an incomplete tar? unless (null outsideDir) $ - logWarn $ T.concat - [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: " - , T.pack (show outsideDir)] + logWarn $ + "Warning: These files are outside of the package directory, and will be omitted from the tarball: " <> + displayShow outsideDir return (nubOrd files) where (outsideDir, files) = partitionEithers (map pathToEither fps) @@ -405,7 +407,7 @@ config <- getDefaultPackageConfig (gdesc, PackageDescriptionPair pkgDesc _) <- readPackageDescriptionDir config pkgDir False logInfo $ - "Checking package '" <> packageNameText name <> "' for common mistakes" + "Checking package '" <> RIO.display name <> "' for common mistakes" let pkgChecks = -- MSS 2017-12-12: Try out a few different variants of -- pkgDesc to try and provoke an error or warning. I don't @@ -429,7 +431,7 @@ in partition criticalIssue checks unless (null warnings) $ logWarn $ "Package check reported the following warnings:\n" <> - T.pack (intercalate "\n" . fmap show $ warnings) + mconcat (intersperse "\n" . fmap displayShow $ warnings) case NE.nonEmpty errors of Nothing -> return () Just ne -> throwM $ CheckException ne diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -12,11 +12,10 @@ import Data.List.Split (splitWhen) import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import qualified Data.Text as T import Path import Path.IO import qualified Stack.Build -import Stack.Exec +import Stack.Constants (osIsWindows) import Stack.GhcPkg (ghcPkgExeName) import Stack.Options.ScriptParser import Stack.Runners @@ -25,7 +24,7 @@ import Stack.Types.Config import Stack.Types.PackageName import System.FilePath (dropExtension, replaceExtension) -import System.Process.Read +import RIO.Process -- | Run a Stack Script scriptCmd :: ScriptOpts -> GlobalOpts -> IO () @@ -38,19 +37,21 @@ , globalStackYaml = SYLNoConfig $ parent file } withBuildConfigAndLock go $ \lk -> do - -- Some warnings in case the user somehow tries to set a - -- stack.yaml location. Note that in this functions we use - -- logError instead of logWarn because, when using the - -- interpreter mode, only error messages are shown. See: - -- https://github.com/commercialhaskell/stack/issues/3007 - case globalStackYaml go' of - SYLOverride fp -> logError $ T.pack - $ "Ignoring override stack.yaml file for script command: " ++ fp - SYLDefault -> return () - SYLNoConfig _ -> assert False (return ()) + -- Some warnings in case the user somehow tries to set a + -- stack.yaml location. Note that in this functions we use + -- logError instead of logWarn because, when using the + -- interpreter mode, only error messages are shown. See: + -- https://github.com/commercialhaskell/stack/issues/3007 + case globalStackYaml go' of + SYLOverride fp -> logError $ + "Ignoring override stack.yaml file for script command: " <> + fromString fp + SYLDefault -> return () + SYLNoConfig _ -> assert False (return ()) - config <- view configL - menv <- liftIO $ configEnvOverride config defaultEnvSettings + config <- view configL + menv <- liftIO $ configProcessContextSettings config defaultEnvSettings + withProcessContext menv $ do wc <- view $ actualCompilerVersionL.whichCompilerL colorFlag <- appropriateGhcColorFlag @@ -71,7 +72,7 @@ -- already. If all needed packages are available, we can -- skip the (rather expensive) build call below. bss <- sinkProcessStdout - Nothing menv (ghcPkgExeName wc) + (ghcPkgExeName wc) ["list", "--simple-output"] CL.consume -- FIXME use the package info from envConfigPackages, or is that crazy? let installed = Set.fromList $ map toPackageName @@ -101,19 +102,20 @@ ] munlockFile lk -- Unlock before transferring control away. case soCompile opts of - SEInterpret -> exec menv ("run" ++ compilerExeName wc) + SEInterpret -> exec ("run" ++ compilerExeName wc) (ghcArgs ++ toFilePath file : soArgs opts) _ -> do let dir = parent file - -- use sinkProcessStdout to ensure a ProcessFailed - -- exception is generated for better error messages - sinkProcessStdout - (Just dir) - menv + -- Use readProcessStdout_ so that (1) if GHC does send any output + -- to stdout, we capture it and stop it from being sent to our + -- stdout, which could break scripts, and (2) if there's an + -- exception, the standard output we did capture will be reported + -- to the user. + withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) (ghcArgs ++ [toFilePath file]) - CL.sinkNull - exec menv (toExeName $ toFilePath file) (soArgs opts) + (void . readProcessStdout_) + exec (toExeName $ toFilePath file) (soArgs opts) where toPackageName = reverse . drop 1 . dropWhile (/= '-') . reverse @@ -121,16 +123,9 @@ wordsComma = splitWhen (\c -> c == ' ' || c == ',') toExeName fp = - if isWindows + if osIsWindows then replaceExtension fp "exe" else dropExtension fp - -isWindows :: Bool -#ifdef WINDOWS -isWindows = True -#else -isWindows = False -#endif getPackagesFromModuleInfo :: ModuleInfo diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -39,14 +39,16 @@ import "cryptonite" Crypto.Hash (SHA1(..), SHA256(..)) import Data.Aeson.Extended import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (isSpace) -import Data.Conduit (Conduit, (=$), await, yield, awaitForever) +import Data.Conduit (await, yield, awaitForever) +import qualified Data.Conduit.Binary as CB import Data.Conduit.Lazy (lazyConsume) import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL -import Data.Conduit.Zlib (ungzip) +import Data.Conduit.Process.Typed (eceStderr) +import Data.Conduit.Zlib (ungzip) import Data.Foldable (maximumBy) import qualified Data.HashMap.Strict as HashMap import Data.IORef.RunOnce (runOnce) @@ -62,21 +64,21 @@ import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) import Lens.Micro (set) -import Network.HTTP.Simple (getResponseBody, httpLBS, withResponse, getResponseStatusCode) +import Network.HTTP.Simple (getResponseBody, getResponseStatusCode) import Network.HTTP.Download import Path import Path.CheckInstall (warnInstallSearchPathIssues) import Path.Extra (toFilePathNoTrailingSep) import Path.IO hiding (findExecutable, withSystemTempDir) import Prelude (getLine, putStr, putStrLn, until) +import qualified RIO import Stack.Build (build) import Stack.Config (loadConfig) import Stack.Constants (stackProgName) import Stack.Constants.Config (distRelativeDir) -import Stack.Exec (defaultEnvSettings) import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar) -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Stack.PrettyPrint import Stack.Setup.Installed import Stack.Snapshot (loadSnapshot) @@ -96,10 +98,7 @@ import System.IO.Error (isPermissionError) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP -import System.Process (rawSystem) -import System.Process.Log (withProcessTimeLog) -import System.Process.Read -import System.Process.Run (runCmd, Cmd(..)) +import RIO.Process import Text.Printf (printf) #if !WINDOWS @@ -145,9 +144,9 @@ deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownCompilerVersion Text (CompilerVersion 'CVWanted) [CompilerVersion 'CVActual] + | UnknownCompilerVersion (Set.Set Text) (CompilerVersion 'CVWanted) (Set.Set (CompilerVersion 'CVActual)) | UnknownOSKey Text - | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) + | GHCSanityCheckCompileFailed SomeException (Path Abs File) | WantedMustBeGHC | RequireCustomGHCVariant | ProblemWhileDecompressing (Path Abs File) @@ -155,6 +154,7 @@ | GHCJSRequiresStandardVariant | GHCJSNotBooted | DockerStackExeNotFound Version Text + | UnsupportedSetupConfiguration deriving Typeable instance Exception SetupException instance Show SetupException where @@ -166,11 +166,13 @@ show (MissingDependencies tools) = "The following executables are missing and must be installed: " ++ intercalate ", " tools - show (UnknownCompilerVersion oskey wanted known) = concat - [ "No information found for " + show (UnknownCompilerVersion oskeys wanted known) = concat + [ "No setup information found for " , compilerVersionString wanted - , ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': " - , intercalate ", " (map show known) + , " on your platform.\nThis probably means a GHC bindist has not yet been added for OS key '" + , T.unpack (T.intercalate "', '" (sort $ Set.toList oskeys)) + , "'.\nSupported versions: " + , T.unpack (T.intercalate ", " (map compilerVersionText (sort $ Set.toList known))) ] show (UnknownOSKey oskey) = "Unable to find installation URLs for OS key: " ++ @@ -204,6 +206,8 @@ , "\nUse the '" , T.unpack dockerStackExeArgName , "' option to specify a location"] + show UnsupportedSetupConfiguration = + "I don't know how to install GHC on your system configuration, please install manually" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too setupEnv :: (HasBuildConfig env, HasGHCVariant env) @@ -237,15 +241,17 @@ -- Modify the initial environment to include the GHC path, if a local GHC -- is being used - menv0 <- getMinimalEnvOverride - env <- removeHaskellEnvVars - <$> augmentPathMap (maybe [] edBins mghcBin) (unEnvOverride menv0) - menv <- mkEnvOverride platform env + menv0 <- view processContextL + env <- either throwM (return . removeHaskellEnvVars) + $ augmentPathMap + (map toFilePath $ maybe [] edBins mghcBin) + (view envVarsL menv0) + menv <- mkProcessContext env - (compilerVer, cabalVer, globaldb) <- runConcurrently $ (,,) - <$> Concurrently (getCompilerVersion menv wc) - <*> Concurrently (getCabalPkgVer menv wc) - <*> Concurrently (getGlobalDB menv wc) + (compilerVer, cabalVer, globaldb) <- withProcessContext menv $ runConcurrently $ (,,) + <$> Concurrently (getCompilerVersion wc) + <*> Concurrently (getCabalPkgVer wc) + <*> Concurrently (getGlobalDB wc) logDebug "Resolving package entries" packagesRef <- liftIO $ newIORef Nothing @@ -255,7 +261,7 @@ -- 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 + bcPath = set processContextL menv bc ls <- runRIO bcPath $ loadSnapshot (Just compilerVer) @@ -273,13 +279,13 @@ -- extra installation bin directories mkDirs <- runReaderT extraBinDirs envConfig0 let mpath = Map.lookup "PATH" env - depsPath <- augmentPath (mkDirs False) mpath - localsPath <- augmentPath (mkDirs True) mpath + depsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs False) mpath + localsPath <- either throwM return $ augmentPath (toFilePath <$> mkDirs True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 - createDatabase menv wc deps + withProcessContext menv $ createDatabase wc deps localdb <- runReaderT packageDatabaseLocal envConfig0 - createDatabase menv wc localdb + withProcessContext menv $ createDatabase wc localdb extras <- runReaderT packageDatabaseExtra envConfig0 let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb @@ -287,17 +293,17 @@ executablePath <- liftIO getExecutablePath - utf8EnvVars <- getUtf8EnvVars menv compilerVer + utf8EnvVars <- withProcessContext menv $ getUtf8EnvVars compilerVer mGhcRtsEnvVar <- liftIO $ lookupEnv "GHCRTS" envRef <- liftIO $ newIORef Map.empty - let getEnvOverride' es = do + let getProcessContext' es = do m <- readIORef envRef case Map.lookup es m of Just eo -> return eo Nothing -> do - eo <- mkEnvOverride platform + eo <- mkProcessContext $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath) $ (if esIncludeGhcPackagePath es then Map.insert (ghcPkgPathEnvVar wc) (mkGPP (esIncludeLocals es)) @@ -342,11 +348,14 @@ (Map.insert es eo m', ()) return eo + envOverride <- liftIO $ getProcessContext' minimalEnvSettings return EnvConfig { envConfigBuildConfig = bconfig { bcConfig = maybe id addIncludeLib mghcBin - (view configL bconfig) - { configEnvOverride = getEnvOverride' } + $ set processContextL envOverride + (view configL bconfig) + { configProcessContextSettings = getProcessContext' + } } , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer @@ -373,19 +382,16 @@ ensureCompiler sopts = do let wc = whichCompiler (soptsWantedCompiler sopts) when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do - logWarn "stack will almost certainly fail with GHC below version 7.8" + logWarn "Stack will almost certainly fail with GHC below version 7.8" logWarn "Valiantly attempting to run anyway, but I know this is doomed" logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" logWarn "" - -- Check the available GHCs - menv0 <- getMinimalEnvOverride - msystem <- if soptsUseSystem sopts then do logDebug "Getting system compiler version" - getSystemCompiler menv0 wc + getSystemCompiler wc else return Nothing Platform expectedArch _ <- view platformL @@ -435,20 +441,30 @@ let localPrograms = configLocalPrograms config installed <- listInstalled localPrograms - (installedCompiler, compilerBuild) <- + possibleCompilers <- case wc of Ghc -> do - ghcBuild <- getGhcBuild menv0 - ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) - return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild) - Ghcjs -> return (getInstalledGhcjs installed isWanted, CompilerBuildStandard) - compilerTool <- case (installedCompiler, soptsForceReinstall sopts) of - (Just tool, False) -> return tool - _ + ghcBuilds <- getGhcBuilds + forM ghcBuilds $ \ghcBuild -> do + ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) + return (getInstalledTool installed ghcPkgName (isWanted . GhcVersion), ghcBuild) + Ghcjs -> return [(getInstalledGhcjs installed isWanted, CompilerBuildStandard)] + let existingCompilers = concatMap + (\(installedCompiler, compilerBuild) -> + case (installedCompiler, soptsForceReinstall sopts) of + (Just tool, False) -> [(tool, compilerBuild)] + _ -> []) + possibleCompilers + logDebug $ + "Found already installed GHC builds: " <> + mconcat (intersperse ", " (map (fromString . compilerBuildName . snd) existingCompilers)) + (compilerTool, compilerBuild) <- case existingCompilers of + (tool, build_):_ -> return (tool, build_) + [] | soptsInstallIfMissing sopts -> do si <- getSetupInfo' - downloadAndInstallCompiler - compilerBuild + downloadAndInstallPossibleCompilers + (map snd possibleCompilers) si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) @@ -458,7 +474,7 @@ if soptsUseSystem sopts then return False else do - msystemGhc <- getSystemCompiler menv0 wc + msystemGhc <- getSystemCompiler wc return (any (uncurry canUseCompiler) msystemGhc) let suggestion = fromMaybe (mconcat @@ -474,7 +490,9 @@ msystem (soptsWantedCompiler sopts, expectedArch) ghcVariant - compilerBuild + (case possibleCompilers of + [] -> CompilerBuildStandard + (_, compilerBuild):_ -> compilerBuild) (soptsCompilerCheck sopts) (soptsStackYaml sopts) suggestion @@ -497,34 +515,37 @@ menv <- case mpaths of - Nothing -> return menv0 + Nothing -> view processContextL Just ed -> do - config <- view configL - m <- augmentPathMap (edBins ed) (unEnvOverride menv0) - mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) + menv0 <- view processContextL + m <- either throwM return + $ augmentPathMap (toFilePath <$> edBins ed) (view envVarsL menv0) + mkProcessContext (removeHaskellEnvVars m) forM_ (soptsUpgradeCabal sopts) $ \version -> do unless needLocal $ do logWarn "Trying to change a Cabal library on a GHC not installed by stack." logWarn "This may fail, caveat emptor!" - upgradeCabal menv wc version + withProcessContext menv $ upgradeCabal wc version case mtools of - Just (Just (ToolGhcjs cv), _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) + Just (Just (ToolGhcjs cv), _) -> + withProcessContext menv + $ ensureGhcjsBooted cv (soptsInstallIfMissing sopts) (soptsGHCJSBootOpts sopts) _ -> return () - when (soptsSanityCheck sopts) $ sanityCheck menv wc + when (soptsSanityCheck sopts) $ withProcessContext menv $ sanityCheck wc return (mpaths, compilerBuild, needLocal) --- | Determine which GHC build to use depending on which shared libraries are available +-- | Determine which GHC builds to use depending on which shared libraries are available -- on the system. -getGhcBuild :: HasConfig env => EnvOverride -> RIO env CompilerBuild -getGhcBuild menv = do +getGhcBuilds :: HasConfig env => RIO env [CompilerBuild] +getGhcBuilds = do config <- view configL case configGHCBuild config of - Just ghcBuild -> return ghcBuild + Just ghcBuild -> return [ghcBuild] Nothing -> determineGhcBuild where determineGhcBuild = do @@ -550,19 +571,22 @@ case platform of Platform _ Cabal.Linux -> do -- Some systems don't have ldconfig in the PATH, so make sure to look in /sbin and /usr/sbin as well - sbinEnv <- modifyEnvOverride menv $ - Map.insert "PATH" $ - "/sbin:/usr/sbin" <> - maybe "" (":" <>) (Map.lookup "PATH" (eoTextMap menv)) - eldconfigOut <- tryProcessStdout Nothing sbinEnv "ldconfig" ["-p"] - egccErrOut <- tryProcessStderrStdout Nothing menv "gcc" ["-v"] + let sbinEnv m = Map.insert + "PATH" + ("/sbin:/usr/sbin" <> maybe "" (":" <>) (Map.lookup "PATH" m)) + m + eldconfigOut + <- withModifyEnvVars sbinEnv + $ proc "ldconfig" ["-p"] + $ tryAny . readProcessStdout_ let firstWords = case eldconfigOut of Right ldconfigOut -> mapMaybe (listToMaybe . T.words) $ - T.lines $ T.decodeUtf8With T.lenientDecode ldconfigOut + T.lines $ T.decodeUtf8With T.lenientDecode + $ LBS.toStrict ldconfigOut Left _ -> [] checkLib lib | libT `elem` firstWords = do - logDebug ("Found shared library " <> libT <> " in 'ldconfig -p' output") + logDebug ("Found shared library " <> libD <> " in 'ldconfig -p' output") return True | otherwise = do #ifdef WINDOWS @@ -575,50 +599,40 @@ -- to scan for shared libs, but this works for our particular case. e <- doesFileExist ($(mkAbsDir "/usr/lib") lib) if e - then logDebug ("Found shared library " <> libT <> " in /usr/lib") - else logDebug ("Did not find shared library " <> libT) + then logDebug ("Found shared library " <> libD <> " in /usr/lib") + else logDebug ("Did not find shared library " <> libD) return e #endif where libT = T.pack (toFilePath lib) - noPie = case egccErrOut of - Right (gccErr,gccOut) -> - "--enable-default-pie" `elem` S8.words gccOutput || "Gentoo Hardened" `S8.isInfixOf` gccOutput - where gccOutput = gccOut <> gccErr - Left _ -> False - logDebug $ if noPie - then "PIE disabled" - else "PIE enabled" + libD = fromString (toFilePath lib) hastinfo5 <- checkLib $(mkRelFile "libtinfo.so.5") hastinfo6 <- checkLib $(mkRelFile "libtinfo.so.6") hasncurses6 <- checkLib $(mkRelFile "libncursesw.so.6") hasgmp5 <- checkLib $(mkRelFile "libgmp.so.10") hasgmp4 <- checkLib $(mkRelFile "libgmp.so.3") - let libComponents = - if | hastinfo6 && hasgmp5 -> ["tinfo6"] - | hastinfo5 && hasgmp5 -> [] - | hasncurses6 && hasgmp5 -> ["ncurses6"] - | hasgmp4 && hastinfo5 -> ["gmp4"] - | otherwise -> [] - pieComponents = - if noPie - then ["nopie"] - else [] - case libComponents ++ pieComponents of - [] -> useBuild CompilerBuildStandard - components -> useBuild (CompilerBuildSpecialized (intercalate "-" components)) + let libComponents = concat + [ [["tinfo6"] | hastinfo6 && hasgmp5] + , [[] | hastinfo5 && hasgmp5] + , [["ncurses6"] | hasncurses6 && hasgmp5 ] + , [["gmp4"] | hasgmp4 ] + ] + useBuilds $ map + (\c -> case c of + [] -> CompilerBuildStandard + _ -> CompilerBuildSpecialized (intercalate "-" c)) + libComponents #if !WINDOWS Platform _ Cabal.OpenBSD -> do releaseStr <- mungeRelease <$> sysRelease - useBuild (CompilerBuildSpecialized releaseStr) + useBuilds [CompilerBuildSpecialized releaseStr] #endif - _ -> useBuild CompilerBuildStandard - useBuild CompilerBuildStandard = do - logDebug "Using standard GHC build" - return CompilerBuildStandard - useBuild (CompilerBuildSpecialized s) = do - logDebug ("Using " <> T.pack s <> " GHC build") - return (CompilerBuildSpecialized s) + _ -> useBuilds [CompilerBuildStandard] + useBuilds builds = do + logDebug $ + "Potential GHC builds: " <> + mconcat (intersperse ", " (map (fromString . compilerBuildName) builds)) + return builds #if !WINDOWS -- | Encode an OpenBSD version (like "6.1") into a valid argument for @@ -634,12 +648,10 @@ prefixMaj = prefixFst "maj" prefixMin prefixMin = prefixFst "min" (map ('r':)) -sysRelease :: (MonadUnliftIO m, MonadLogger m) => m String +sysRelease :: HasLogFunc env => RIO env String sysRelease = handleIO (\e -> do - logWarn $ T.concat [ T.pack "Could not query OS version" - , T.pack $ show e - ] + logWarn $ "Could not query OS version" <> displayShow e return "") . liftIO . alloca $ \ ptr -> @@ -658,7 +670,10 @@ let stackExePath = stackExeDir $(mkRelFile "stack") stackExeExists <- doesFileExist stackExePath unless stackExeExists $ do - logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"] + logInfo $ + "Downloading Docker-compatible " <> + fromString stackProgName <> + " executable" sri <- downloadStackReleaseInfo Nothing Nothing (Just (versionString stackMinorVersion)) platforms <- runReaderT preferredPlatforms (containerPlatform, PlatformVariantNone) downloadStackExe platforms sri stackExeDir False (const $ return ()) @@ -666,56 +681,54 @@ -- | Install the newest version or a specific version of Cabal globally upgradeCabal :: (HasConfig env, HasGHCVariant env) - => EnvOverride - -> WhichCompiler + => WhichCompiler -> UpgradeTo -> RIO env () -upgradeCabal menv wc upgradeTo = do +upgradeCabal wc upgradeTo = do logInfo "Manipulating the global Cabal is only for debugging purposes" let name = $(mkPackageName "Cabal") rmap <- resolvePackages Nothing mempty (Set.singleton name) - installed <- getCabalPkgVer menv wc + installed <- getCabalPkgVer wc case upgradeTo of Specific wantedVersion -> do if installed /= wantedVersion then - doCabalInstall menv wc installed wantedVersion + doCabalInstall wc installed wantedVersion else - logInfo $ T.concat ["No install necessary. Cabal " - , T.pack $ versionString installed - , " is already installed"] + logInfo $ + "No install necessary. Cabal " <> + RIO.display installed <> + " is already installed" Latest -> case map rpIdent rmap of [] -> throwString "No Cabal library found in index, cannot upgrade" [PackageIdentifier name' latestVersion] | name == name' -> do if installed < latestVersion then - doCabalInstall menv wc installed latestVersion + doCabalInstall wc installed latestVersion else - logInfo $ T.concat - [ "No upgrade necessary: Cabal-" - , T.pack $ versionString latestVersion - , " is the same or newer than latest hackage version " - , T.pack $ versionString installed - ] + logInfo $ + "No upgrade necessary: Cabal-" <> + RIO.display latestVersion <> + " is the same or newer than latest hackage version " <> + RIO.display installed x -> error $ "Unexpected results for resolvePackages: " ++ show x -- Configure and run the necessary commands for a cabal install doCabalInstall :: (HasConfig env, HasGHCVariant env) - => EnvOverride - -> WhichCompiler + => WhichCompiler -> Version -> Version -> RIO env () -doCabalInstall menv wc installed wantedVersion = do +doCabalInstall wc installed wantedVersion = do withSystemTempDir "stack-cabal-upgrade" $ \tmpdir -> do - logInfo $ T.concat - [ "Installing Cabal-" - , T.pack $ versionString wantedVersion - , " to replace " - , T.pack $ versionString installed - ] + logInfo $ + "Installing Cabal-" <> + RIO.display wantedVersion <> + " to replace " <> + RIO.display installed let name = $(mkPackageName "Cabal") ident = PackageIdentifier name wantedVersion m <- unpackPackageIdents tmpdir Nothing [PackageIdentifierRevision ident CFILatest] - compilerPath <- join $ findExecutable menv (compilerExeName wc) + compilerPath <- findExecutable (compilerExeName wc) + >>= either throwM parseAbsFile versionDir <- parseRelDir $ versionString wantedVersion let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") @@ -723,7 +736,7 @@ dir <- case Map.lookup ident m of Nothing -> error "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir - runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing + withWorkingDir (toFilePath dir) $ proc (compilerExeName wc) ["Setup.hs"] runProcess_ platform <- view platformL let setupExe = toFilePath $ dir case platform of Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe") @@ -734,35 +747,35 @@ , installRoot FP. name' ] args = "configure" : map dirArgument (words "lib bin data doc") - runCmd (Cmd (Just dir) setupExe menv args) Nothing - runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing - runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing + withWorkingDir (toFilePath dir) $ do + proc setupExe args runProcess_ + proc setupExe ["build"] runProcess_ + proc setupExe ["install"] runProcess_ logInfo "New Cabal library installed" -- | Get the version of the system compiler, if available getSystemCompiler - :: HasLogFunc env - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> RIO env (Maybe (CompilerVersion 'CVActual, Arch)) -getSystemCompiler menv wc = do +getSystemCompiler wc = do let exeName = case wc of Ghc -> "ghc" Ghcjs -> "ghcjs" - exists <- doesExecutableExist menv exeName + exists <- doesExecutableExist exeName if exists then do - eres <- tryProcessStdout Nothing menv exeName ["--info"] + eres <- proc exeName ["--info"] $ tryAny . readProcessStdout_ let minfo = do - Right bs <- Just eres - pairs_ <- readMaybe $ S8.unpack bs :: Maybe [(String, String)] + Right lbs <- Just eres + pairs_ <- readMaybe $ BL8.unpack lbs :: Maybe [(String, String)] version <- lookup "Project version" pairs_ >>= parseVersionFromString arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) case (wc, minfo) of (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch)) (Ghcjs, Just (_, arch)) -> do - eversion <- tryAny $ getCompilerVersion menv Ghcjs + eversion <- tryAny $ getCompilerVersion Ghcjs case eversion of Left _ -> return Nothing Right version -> return (Just (version, arch)) @@ -878,10 +891,10 @@ "Preparing to install GHC" <> (case ghcVariant of GHCStandard -> "" - v -> " (" <> T.pack (ghcVariantName v) <> ")") <> + v -> " (" <> fromString (ghcVariantName v) <> ")") <> (case ghcBuild of CompilerBuildStandard -> "" - b -> " (" <> T.pack (compilerBuildName b) <> ")") <> + b -> " (" <> fromString (compilerBuildName b) <> ")") <> " to an isolated location." logInfo "This will not interfere with any system-level installation." ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant ++ compilerBuildSuffix ghcBuild) @@ -911,13 +924,56 @@ getWantedCompilerInfo key versionCheck wanted toCV pairs_ = case mpair of Just pair -> return pair - Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs_)) + Nothing -> throwM $ UnknownCompilerVersion (Set.singleton key) wanted (Set.fromList $ map toCV (Map.keys pairs_)) where mpair = listToMaybe $ sortBy (flip (comparing fst)) $ filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) +-- | Download and install the first available compiler build. +downloadAndInstallPossibleCompilers + :: (HasGHCVariant env, HasConfig env) + => [CompilerBuild] + -> SetupInfo + -> CompilerVersion 'CVWanted + -> VersionCheck + -> Maybe String + -> RIO env (Tool, CompilerBuild) +downloadAndInstallPossibleCompilers possibleCompilers si wanted versionCheck mbindistURL = + go possibleCompilers Nothing + where + -- This will stop as soon as one of the builds doesn't throw an @UnknownOSKey@ or + -- @UnknownCompilerVersion@ exception (so it will only try subsequent builds if one is non-existent, + -- not if the download or install fails for some other reason). + -- The @Unknown*@ exceptions thrown by each attempt are combined into a single exception + -- (if only @UnknownOSKey@ is thrown, then the first of those is rethrown, but if any + -- @UnknownCompilerVersion@s are thrown then the attempted OS keys and available versions + -- are unioned). + go [] Nothing = throwM UnsupportedSetupConfiguration + go [] (Just e) = throwM e + go (b:bs) e = do + logDebug $ "Trying to setup GHC build: " <> fromString (compilerBuildName b) + er <- try $ downloadAndInstallCompiler b si wanted versionCheck mbindistURL + case er of + Left e'@(UnknownCompilerVersion ks' w' vs') -> + case e of + Nothing -> go bs (Just e') + Just (UnknownOSKey k) -> + go bs $ Just $ UnknownCompilerVersion (Set.insert k ks') w' vs' + Just (UnknownCompilerVersion ks _ vs) -> + go bs $ Just $ UnknownCompilerVersion (Set.union ks' ks) w' (Set.union vs' vs) + Just x -> throwM x + Left e'@(UnknownOSKey k') -> + case e of + Nothing -> go bs (Just e') + Just (UnknownOSKey _) -> go bs e + Just (UnknownCompilerVersion ks w vs) -> + go bs $ Just $ UnknownCompilerVersion (Set.insert k' ks) w vs + Just x -> throwM x + Left e' -> throwM e' + Right r -> return (r, b) + getGhcKey :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) => CompilerBuild -> m Text getGhcKey ghcBuild = do @@ -930,17 +986,18 @@ => Platform -> m Text getOSKey platform = case platform of - Platform I386 Cabal.Linux -> return "linux32" - Platform X86_64 Cabal.Linux -> return "linux64" - Platform I386 Cabal.OSX -> return "macosx" - Platform X86_64 Cabal.OSX -> return "macosx" - Platform I386 Cabal.FreeBSD -> return "freebsd32" - Platform X86_64 Cabal.FreeBSD -> return "freebsd64" - Platform I386 Cabal.OpenBSD -> return "openbsd32" - Platform X86_64 Cabal.OpenBSD -> return "openbsd64" - Platform I386 Cabal.Windows -> return "windows32" - Platform X86_64 Cabal.Windows -> return "windows64" - Platform Arm Cabal.Linux -> return "linux-armv7" + Platform I386 Cabal.Linux -> return "linux32" + Platform X86_64 Cabal.Linux -> return "linux64" + Platform I386 Cabal.OSX -> return "macosx" + Platform X86_64 Cabal.OSX -> return "macosx" + Platform I386 Cabal.FreeBSD -> return "freebsd32" + Platform X86_64 Cabal.FreeBSD -> return "freebsd64" + Platform I386 Cabal.OpenBSD -> return "openbsd32" + Platform X86_64 Cabal.OpenBSD -> return "openbsd64" + Platform I386 Cabal.Windows -> return "windows32" + Platform X86_64 Cabal.Windows -> return "windows64" + Platform Arm Cabal.Linux -> return "linux-armv7" + Platform (OtherArch "aarch64") Cabal.Linux -> return "linux-aarch64" Platform arch os -> throwM $ UnsupportedSetupCombo os arch downloadFromInfo @@ -1005,9 +1062,9 @@ -> RIO env () installGHCPosix version downloadInfo _ archiveFile archiveType tempDir destDir = do platform <- view platformL - menv0 <- getMinimalEnvOverride - menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0)) - logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) + menv0 <- view processContextL + menv <- mkProcessContext (removeHaskellEnvVars (view envVarsL menv0)) + logDebug $ "menv = " <> displayShow (view envVarsL menv) (zipTool', compOpt) <- case archiveType of TarXz -> return ("xz", 'J') @@ -1025,9 +1082,9 @@ <*> (checkDependency "gmake" <|> checkDependency "make") <*> tarDep - logDebug $ "ziptool: " <> T.pack zipTool - logDebug $ "make: " <> T.pack makeTool - logDebug $ "tar: " <> T.pack tarTool + logDebug $ "ziptool: " <> fromString zipTool + logDebug $ "make: " <> fromString makeTool + logDebug $ "tar: " <> fromString tarTool dir <- liftM (tempDir ) $ @@ -1035,12 +1092,18 @@ "ghc-" ++ versionString version let runStep step wd env cmd args = do - menv' <- modifyEnvOverride menv (Map.union env) - result <- try (readProcessNull (Just wd) menv' cmd args) + menv' <- modifyEnvVars menv (Map.union env) + result <- do + let logLines = CB.lines .| CL.mapM_ (logDebug . displayBytesUtf8) + withWorkingDir (toFilePath wd) + $ withProcessContext menv' + $ try + $ sinkProcessStderrStdout cmd args logLines logLines + case result of - Right _ -> return () + Right ((), ()) -> return () Left ex -> do - logError (T.pack (show (ex :: ReadProcessException))) + logError (displayShow (ex :: ProcessException)) prettyError $ hang 2 ("Error encountered while" <+> step <+> "GHC with" <> line <> @@ -1053,8 +1116,11 @@ " -" <+> display destDir <> line liftIO exitFailure - logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ tempDir, " ..."] - logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) + logSticky $ + "Unpacking GHC into " <> + fromString (toFilePath tempDir) <> + " ..." + logDebug $ "Unpacking " <> fromString (toFilePath archiveFile) runStep "unpacking" tempDir mempty tarTool [compOpt : "xf", toFilePath archiveFile] logSticky "Configuring GHC ..." @@ -1067,7 +1133,7 @@ runStep "installing" dir mempty makeTool ["install"] logStickyDone $ "Installed GHC." - logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) + logDebug $ "GHC installed to " <> fromString (toFilePath destDir) installGHCJS :: HasConfig env => SetupInfo @@ -1078,12 +1144,12 @@ -> RIO env () installGHCJS si archiveFile archiveType _tempDir destDir = do platform <- view platformL - menv0 <- getMinimalEnvOverride + menv0 <- view processContextL -- This ensures that locking is disabled for the invocations of -- stack below. let removeLockVar = Map.delete "STACK_LOCK" - menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0))) - logDebug $ "menv = " <> T.pack (show (unEnvOverride menv)) + menv <- mkProcessContext (removeLockVar (removeHaskellEnvVars (view envVarsL menv0))) + logDebug $ "menv = " <> displayShow (view envVarsL menv) -- NOTE: this is a bit of a hack - instead of using the temp -- directory, leave the unpacked source tarball in the destination @@ -1110,17 +1176,20 @@ (zipTool, tarTool) <- checkDependencies $ (,) <$> checkDependency zipTool' <*> checkDependency "tar" - logDebug $ "ziptool: " <> T.pack zipTool - logDebug $ "tar: " <> T.pack tarTool + logDebug $ "ziptool: " <> fromString zipTool + logDebug $ "tar: " <> fromString tarTool return $ do liftIO $ ignoringAbsence (removeDirRecur destDir) liftIO $ ignoringAbsence (removeDirRecur unpackDir) - readProcessNull (Just destDir) menv tarTool ["xf", toFilePath archiveFile] + withProcessContext menv $ withWorkingDir (toFilePath destDir) $ readProcessNull tarTool ["xf", toFilePath archiveFile] innerDir <- expectSingleUnpackedDir archiveFile destDir renameDir innerDir unpackDir - logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] - logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) + logSticky $ + "Unpacking GHCJS into " <> + fromString (toFilePath unpackDir) <> + " ..." + logDebug $ "Unpacking " <> fromString (toFilePath archiveFile) runUnpack logSticky "Setting up GHCJS build environment" @@ -1149,15 +1218,15 @@ logStickyDone "Installed GHCJS." ensureGhcjsBooted :: HasConfig env - => EnvOverride -> CompilerVersion 'CVActual -> Bool -> [String] + => CompilerVersion 'CVActual -> Bool -> [String] -> RIO env () -ensureGhcjsBooted menv cv shouldBoot bootOpts = do - eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ()) +ensureGhcjsBooted cv shouldBoot bootOpts = do + eres <- try $ sinkProcessStdout "ghcjs" [] (return ()) case eres of Right () -> return () - Left (ProcessFailed _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err -> + Left ece | "no input files" `S.isInfixOf` LBS.toStrict (eceStderr ece) -> return () - Left (ProcessFailed _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err -> + Left ece | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict (eceStderr ece) -> if not shouldBoot then throwM GHCJSNotBooted else do config <- view configL destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv) @@ -1182,15 +1251,15 @@ unless actualStackYamlExists $ throwString "Error: Couldn't find GHCJS stack.yaml in old or new location." bootGhcjs ghcjsVersion actualStackYaml destDir bootOpts - Left err -> throwM err + Left ece -> throwIO ece -bootGhcjs :: HasRunner env +bootGhcjs :: (HasRunner env, HasProcessContext env) => Version -> Path Abs File -> Path Abs Dir -> [String] -> RIO env () bootGhcjs ghcjsVersion stackYaml destDir bootOpts = do envConfig <- loadGhcjsEnvConfig stackYaml (destDir $(mkRelDir "bin")) - menv <- liftIO $ configEnvOverride (view configL envConfig) defaultEnvSettings + menv <- liftIO $ configProcessContextSettings (view configL envConfig) defaultEnvSettings -- Install cabal-install if missing, or if the installed one is old. - mcabal <- getCabalInstallVersion menv + mcabal <- withProcessContext menv getCabalInstallVersion shouldInstallCabal <- case mcabal of Nothing -> do logInfo "No cabal-install binary found for use with GHCJS." @@ -1199,20 +1268,20 @@ | v < $(mkVersion "1.22.4") -> do logInfo $ "The cabal-install found on PATH is too old to be used for booting GHCJS (version " <> - versionText v <> + RIO.display v <> ")." return True | v >= $(mkVersion "1.23") -> do logWarn $ "The cabal-install found on PATH is a version stack doesn't know about, version " <> - versionText v <> + RIO.display v <> ". This may or may not work.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" return False | ghcjsVersion >= $(mkVersion "0.2.0.20160413") && v >= $(mkVersion "1.22.8") -> do logWarn $ "The cabal-install found on PATH, version " <> - versionText v <> + RIO.display v <> ", is >= 1.22.8.\n" <> "That version has a bug preventing ghcjs < 0.2.0.20160413 from booting.\n" <> "See this issue: https://github.com/ghcjs/ghcjs/issues/470" @@ -1225,21 +1294,21 @@ , esLocaleUtf8 = True , esKeepGhcRts = False } - menv' <- liftIO $ configEnvOverride (view configL envConfig) envSettings - shouldInstallAlex <- not <$> doesExecutableExist menv "alex" - shouldInstallHappy <- not <$> doesExecutableExist menv "happy" + menv' <- liftIO $ configProcessContextSettings (view configL envConfig) envSettings + shouldInstallAlex <- runRIO menv $ not <$> doesExecutableExist "alex" + shouldInstallHappy <- runRIO menv $ not <$> doesExecutableExist "happy" let bootDepsToInstall = [ "cabal-install" | shouldInstallCabal ] ++ [ "alex" | shouldInstallAlex ] ++ [ "happy" | shouldInstallHappy ] when (not (null bootDepsToInstall)) $ do - logInfo $ "Building tools from source, needed for ghcjs-boot: " <> T.pack (show bootDepsToInstall) + logInfo $ "Building tools from source, needed for ghcjs-boot: " <> displayShow bootDepsToInstall buildInGhcjsEnv envConfig $ defaultBuildOptsCLI { boptsCLITargets = bootDepsToInstall } let failedToFindErr = do logError "This shouldn't happen, because it gets built to the snapshot bin directory, which should be treated as being on the PATH." liftIO exitFailure when shouldInstallCabal $ do - mcabal' <- getCabalInstallVersion menv' + mcabal' <- withProcessContext menv' getCabalInstallVersion case mcabal' of Nothing -> do logError "Failed to get cabal-install version after installing it." @@ -1251,17 +1320,17 @@ "This version is specified by the stack.yaml file included in the ghcjs tarball.\n" _ -> return () when shouldInstallAlex $ do - alexInstalled <- doesExecutableExist menv "alex" + alexInstalled <- runRIO menv $ doesExecutableExist "alex" when (not alexInstalled) $ do logError "Failed to find 'alex' executable after installing it." failedToFindErr when shouldInstallHappy $ do - happyInstalled <- doesExecutableExist menv "happy" + happyInstalled <- runRIO menv $ doesExecutableExist "happy" when (not happyInstalled) $ do logError "Failed to find 'happy' executable after installing it." failedToFindErr logSticky "Booting GHCJS (this will take a long time) ..." - logProcessStderrStdout Nothing "ghcjs-boot" menv' bootOpts + withProcessContext menv' $ proc "ghcjs-boot" bootOpts logProcessStderrStdout logStickyDone "GHCJS booted." loadGhcjsEnvConfig :: HasRunner env @@ -1283,45 +1352,42 @@ set (buildOptsL.buildOptsHaddockL) False envConfig) $ build (\_ -> return ()) Nothing boptsCli -getCabalInstallVersion :: HasLogFunc env => EnvOverride -> RIO env (Maybe Version) -getCabalInstallVersion menv = do - ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"] - liftIO $ case ebs of +getCabalInstallVersion :: (HasProcessContext env, HasLogFunc env) => RIO env (Maybe Version) +getCabalInstallVersion = do + ebs <- proc "cabal" ["--numeric-version"] $ tryAny . readProcessStdout_ + case ebs of Left _ -> return Nothing - Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 bs)) + Right bs -> Just <$> parseVersion (T.dropWhileEnd isSpace (T.decodeUtf8 (LBS.toStrict bs))) -- | Check if given processes appear to be present, throwing an exception if -- missing. -checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env) - => CheckDependency a -> m a -checkDependencies (CheckDependency f) = do - menv <- getMinimalEnvOverride - liftIO (f menv) >>= either (throwM . MissingDependencies) return +checkDependencies :: CheckDependency env a -> RIO env a +checkDependencies (CheckDependency f) = f >>= either (throwIO . MissingDependencies) return -checkDependency :: String -> CheckDependency String -checkDependency tool = CheckDependency $ \menv -> do - exists <- doesExecutableExist menv tool +checkDependency :: HasProcessContext env => String -> CheckDependency env String +checkDependency tool = CheckDependency $ do + exists <- doesExecutableExist tool return $ if exists then Right tool else Left [tool] -newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a)) +newtype CheckDependency env a = CheckDependency (RIO env (Either [String] a)) deriving Functor -instance Applicative CheckDependency where - pure x = CheckDependency $ \_ -> return (Right x) - CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do - f' <- f menv - x' <- x menv +instance Applicative (CheckDependency env) where + pure x = CheckDependency $ return (Right x) + CheckDependency f <*> CheckDependency x = CheckDependency $ do + f' <- f + x' <- x return $ case (f', x') of (Left e1, Left e2) -> Left $ e1 ++ e2 (Left e, Right _) -> Left e (Right _, Left e) -> Left e (Right f'', Right x'') -> Right $ f'' x'' -instance Alternative CheckDependency where - empty = CheckDependency $ \_ -> return $ Left [] - CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do - res1 <- x menv +instance Alternative (CheckDependency env) where + empty = CheckDependency $ return $ Left [] + CheckDependency x <|> CheckDependency y = CheckDependency $ do + res1 <- x case res1 of - Left _ -> y menv + Left _ -> y Right x' -> return $ Right x' installGHCWindows :: HasConfig env @@ -1335,7 +1401,7 @@ installGHCWindows version si archiveFile archiveType _tempDir destDir = do tarComponent <- parseRelDir $ "ghc-" ++ versionString version withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir - logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) + logInfo $ "GHC installed to " <> fromString (toFilePath destDir) installMsys2Windows :: HasConfig env => Text -- ^ OS Key @@ -1348,9 +1414,9 @@ installMsys2Windows osKey si archiveFile archiveType _tempDir destDir = do exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do - logError $ T.pack $ - "Could not delete existing msys directory: " ++ - toFilePath destDir + logError $ + "Could not delete existing msys directory: " <> + fromString (toFilePath destDir) throwM e msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey) @@ -1360,13 +1426,14 @@ -- I couldn't find this officially documented anywhere, but you need to run -- the MSYS shell once in order to initialize some pacman stuff. Once that -- run happens, you can just run commands as usual. - platform <- view platformL - menv0 <- getMinimalEnvOverride - newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS" - newEnv <- augmentPathMap [destDir $(mkRelDir "usr") $(mkRelDir "bin")] - (unEnvOverride newEnv0) - menv <- mkEnvOverride platform newEnv - runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing + menv0 <- view processContextL + newEnv0 <- modifyEnvVars menv0 $ Map.insert "MSYSTEM" "MSYS" + newEnv <- either throwM return $ augmentPathMap + [toFilePath $ destDir $(mkRelDir "usr") $(mkRelDir "bin")] + (view envVarsL newEnv0) + menv <- mkProcessContext newEnv + withWorkingDir (toFilePath destDir) $ withProcessContext menv + $ proc "sh" ["--login", "-c", "true"] runProcess_ -- No longer installing git, it's unreliable -- (https://github.com/commercialhaskell/stack/issues/1046) and the @@ -1412,7 +1479,7 @@ expectSingleUnpackedDir archiveFile destDir = do contents <- listDir destDir case contents of - ([dir], []) -> return dir + ([dir], _ ) -> return dir _ -> throwString $ "Expected a single directory within unpacked " ++ toFilePath archiveFile -- | Download 7z as necessary, and get a function for unpacking things. @@ -1438,8 +1505,7 @@ , "-y" , toFilePath archive ] - ec <- withProcessTimeLog cmd args $ - liftIO $ rawSystem cmd args + ec <- proc cmd args runProcess when (ec /= ExitSuccess) $ liftIO $ throwM (ProblemWhileDecompressing archive) _ -> throwM SetupInfoMissingSevenz @@ -1452,18 +1518,16 @@ chattyDownload label downloadInfo path = do let url = downloadInfoUrl downloadInfo req <- parseUrlThrow $ T.unpack url - logSticky $ T.concat - [ "Preparing to download " - , label - , " ..." - ] - logDebug $ T.concat - [ "Downloading from " - , url - , " to " - , T.pack $ toFilePath path - , " ..." - ] + logSticky $ + "Preparing to download " <> + RIO.display label <> + " ..." + logDebug $ + "Downloading from " <> + RIO.display url <> + " to " <> + fromString (toFilePath path) <> + " ..." hashChecks <- fmap catMaybes $ forM [ ("sha1", HashCheck SHA1, downloadInfoSha1) , ("sha256", HashCheck SHA256, downloadInfoSha256) @@ -1471,42 +1535,38 @@ $ \(name, constr, getter) -> case getter downloadInfo of Just bs -> do - logDebug $ T.concat - [ "Will check against " - , name - , " hash: " - , T.decodeUtf8With T.lenientDecode bs - ] + logDebug $ + "Will check against " <> + name <> + " hash: " <> + displayBytesUtf8 bs return $ Just $ constr $ CheckHexDigestByteString bs Nothing -> return Nothing - when (null hashChecks) $ logWarn $ T.concat - [ "No sha1 or sha256 found in metadata," - , " download hash won't be checked." - ] + when (null hashChecks) $ logWarn $ + "No sha1 or sha256 found in metadata," <> + " download hash won't be checked." let dReq = DownloadRequest { drRequest = req , drHashChecks = hashChecks , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } - run <- askRunInIO - x <- verifiedDownload dReq path (chattyDownloadProgress run) + x <- verifiedDownload dReq path chattyDownloadProgress if x - then logStickyDone ("Downloaded " <> label <> ".") + then logStickyDone ("Downloaded " <> RIO.display label <> ".") else logStickyDone "Already downloaded." where mtotalSize = downloadInfoContentLength downloadInfo - chattyDownloadProgress runInBase _ = do - _ <- liftIO $ runInBase $ logSticky $ - label <> ": download has begun" + chattyDownloadProgress _ = do + _ <- logSticky $ RIO.display label <> ": download has begun" CL.map (Sum . S.length) - =$ chunksOverTime 1 - =$ go + .| chunksOverTime 1 + .| go where go = evalStateC 0 $ awaitForever $ \(Sum size) -> do modify (+ size) totalSoFar <- get - liftIO $ runInBase $ logSticky $ T.pack $ + logSticky $ fromString $ case mtotalSize of Nothing -> chattyProgressNoTotal totalSoFar Just 0 -> chattyProgressNoTotal totalSoFar @@ -1550,7 +1610,7 @@ -- The final yield may come sooner, and may be a superfluous mempty. -- Note that Integer and Float literals can be turned into NominalDiffTime -- (these literals are interpreted as "seconds") -chunksOverTime :: (Monoid a, MonadIO m) => NominalDiffTime -> Conduit a m a +chunksOverTime :: (Monoid a, Semigroup a, MonadIO m) => NominalDiffTime -> ConduitM a a m () chunksOverTime diff = do currentTime <- liftIO getCurrentTime evalStateC (currentTime, mempty) go @@ -1572,23 +1632,22 @@ go -- | Perform a basic sanity check of GHC -sanityCheck :: HasLogFunc env - => EnvOverride - -> WhichCompiler +sanityCheck :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> RIO env () -sanityCheck menv wc = withSystemTempDir "stack-sanity-check" $ \dir -> do +sanityCheck wc = withSystemTempDir "stack-sanity-check" $ \dir -> do let fp = toFilePath $ dir $(mkRelFile "Main.hs") liftIO $ S.writeFile fp $ T.encodeUtf8 $ T.pack $ unlines [ "import Distribution.Simple" -- ensure Cabal library is present , "main = putStrLn \"Hello World\"" ] let exeName = compilerExeName wc - ghc <- liftIO $ join $ findExecutable menv exeName - logDebug $ "Performing a sanity check on: " <> T.pack (toFilePath ghc) - eres <- tryProcessStdout (Just dir) menv exeName + ghc <- findExecutable exeName >>= either throwM parseAbsFile + logDebug $ "Performing a sanity check on: " <> fromString (toFilePath ghc) + eres <- withWorkingDir (toFilePath dir) $ proc exeName [ fp , "-no-user-package-db" - ] + ] $ try . readProcessStdout_ case eres of Left e -> throwIO $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct @@ -1608,17 +1667,17 @@ -- | Get map of environment variables to set to change the GHC's encoding to UTF-8 getUtf8EnvVars - :: (HasLogFunc env, HasPlatform env) - => EnvOverride - -> CompilerVersion 'CVActual + :: (HasProcessContext env, HasPlatform env, HasLogFunc env) + => CompilerVersion 'CVActual -> RIO env (Map Text Text) -getUtf8EnvVars menv compilerVer = +getUtf8EnvVars compilerVer = if getGhcVersion compilerVer >= $(mkVersion "7.10.3") -- GHC_CHARENC supported by GHC >=7.10.3 then return $ Map.singleton "GHC_CHARENC" "UTF-8" else legacyLocale where legacyLocale = do + menv <- view processContextL Platform _ os <- view platformL if os == Cabal.Windows then @@ -1627,7 +1686,7 @@ return Map.empty else do - let checkedVars = map checkVar (Map.toList $ eoTextMap menv) + let checkedVars = map checkVar (Map.toList $ view envVarsL menv) -- List of environment variables that will need to be updated to set UTF-8 (because -- they currently do not specify UTF-8). needChangeVars = concatMap fst checkedVars @@ -1644,7 +1703,7 @@ Map.empty else do -- Get a list of known locales by running @locale -a@. - elocales <- tryProcessStdout Nothing menv "locale" ["-a"] + elocales <- tryAny $ proc "locale" ["-a"] readProcessStdout_ let -- Filter the list to only include locales with UTF-8 encoding. utf8Locales = @@ -1655,8 +1714,8 @@ isUtf8Locale (T.lines $ T.decodeUtf8With - T.lenientDecode - locales) + T.lenientDecode $ + LBS.toStrict locales) mfallback = getFallbackLocale utf8Locales when (isNothing mfallback) @@ -1667,7 +1726,7 @@ changes = Map.unions $ map - (adjustedVarValue utf8Locales mfallback) + (adjustedVarValue menv utf8Locales mfallback) needChangeVars -- Get the values of variables to add. adds @@ -1697,9 +1756,9 @@ -- same language /and/ territory, then with same language, and finally the first UTF-8 locale -- returned by @locale -a@. adjustedVarValue - :: [Text] -> Maybe Text -> Text -> Map Text Text - adjustedVarValue utf8Locales mfallback k = - case Map.lookup k (eoTextMap menv) of + :: ProcessContext -> [Text] -> Maybe Text -> Text -> Map Text Text + adjustedVarValue menv utf8Locales mfallback k = + case Map.lookup k (view envVarsL menv) of Nothing -> Map.empty Just v -> case concatMap @@ -1802,7 +1861,7 @@ ++ unwords (map snd platforms0) loop ((isWindows, p'):ps) = do let p = T.pack p' - logInfo $ "Querying for archive location for platform: " <> p + logInfo $ "Querying for archive location for platform: " <> fromString p' case findArchive archiveInfo p of Just x -> return (isWindows, x) Nothing -> loop ps @@ -1818,7 +1877,7 @@ , destDir $(mkRelFile "stack.tmp") ) - logInfo $ "Downloading from: " <> archiveURL + logInfo $ "Downloading from: " <> RIO.display archiveURL liftIO $ do case () of @@ -1849,10 +1908,10 @@ destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir warnInstallSearchPathIssues destDir' ["stack"] - logInfo $ T.pack $ "New stack executable available at " ++ toFilePath destFile + logInfo $ "New stack executable available at " <> fromString (toFilePath destFile) when checkPath $ performPathChecking destFile - `catchAny` \e -> logError (T.pack (show e)) + `catchAny` (logError . displayShow) where findArchive (StackReleaseInfo val) pattern = do @@ -1915,7 +1974,7 @@ executablePath <- liftIO getExecutablePath executablePath' <- parseAbsFile executablePath unless (toFilePath newFile == executablePath) $ do - logInfo $ T.pack $ "Also copying stack executable to " ++ executablePath + logInfo $ "Also copying stack executable to " <> fromString executablePath tmpFile <- parseAbsFile $ executablePath ++ ".tmp" eres <- tryIO $ do liftIO $ copyFile newFile tmpFile @@ -1928,13 +1987,12 @@ Right () -> return () Left e | isPermissionError e -> do - logWarn $ T.pack $ "Permission error when trying to copy: " ++ show e + logWarn $ "Permission error when trying to copy: " <> displayShow e logWarn "Should I try to perform the file copy using sudo? This may fail" toSudo <- prompt "Try using sudo? (y/n) " when toSudo $ do let run cmd args = do - ec <- withProcessTimeLog cmd args $ - liftIO $ rawSystem cmd args + ec <- proc cmd args runProcess when (ec /= ExitSuccess) $ error $ concat [ "Process exited with " , show ec @@ -1956,7 +2014,7 @@ logInfo "Going to run the following commands:" logInfo "" forM_ commands $ \(cmd, args) -> - logInfo $ "- " `T.append` T.unwords (map T.pack (cmd:args)) + logInfo $ "- " <> mconcat (intersperse " " (fromString <$> (cmd:args))) mapM_ (uncurry run) commands logInfo "" logInfo "sudo file copy worked!" diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -26,6 +26,7 @@ import Stack.Prelude import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as BL import Data.List hiding (concat, elem, maximumBy) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -39,7 +40,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read +import RIO.Process data Tool = Tool PackageIdentifier -- ^ e.g. ghc-7.8.4, msys2-20150512 @@ -88,26 +89,25 @@ parseToolText x getCompilerVersion - :: HasLogFunc env - => EnvOverride - -> WhichCompiler + :: (HasProcessContext env, HasLogFunc env) + => WhichCompiler -> RIO env (CompilerVersion 'CVActual) -getCompilerVersion menv wc = +getCompilerVersion wc = case wc of Ghc -> do logDebug "Asking GHC for its version" - bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] - let (_, ghcVersion) = versionFromEnd bs + bs <- proc "ghc" ["--numeric-version"] readProcessStdout_ + let (_, ghcVersion) = versionFromEnd $ BL.toStrict bs x <- GhcVersion <$> parseVersion (T.decodeUtf8 ghcVersion) - logDebug $ "GHC version is: " <> compilerVersionText x + logDebug $ "GHC version is: " <> display x return x Ghcjs -> do logDebug "Asking GHCJS for its version" -- Output looks like -- -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) - bs <- readProcessStdout Nothing menv "ghcjs" ["--version"] - let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd bs + bs <- proc "ghcjs" ["--version"] readProcessStdout_ + let (rest, ghcVersion) = T.decodeUtf8 <$> versionFromEnd (BL.toStrict bs) (_, ghcjsVersion) = T.decodeUtf8 <$> versionFromEnd rest GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion where @@ -165,7 +165,7 @@ ] } (Platform _ x, toolName) -> do - logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) + logWarn $ "binDirs: unexpected OS/tool combo: " <> displayShow (x, toolName) return mempty where isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n @@ -176,9 +176,11 @@ , edInclude :: ![Path Abs Dir] , edLib :: ![Path Abs Dir] } deriving (Show, Generic) +instance Semigroup ExtraDirs where + (<>) = mappenddefault instance Monoid ExtraDirs where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) installDir :: (MonadReader env m, MonadThrow m) => Path Abs Dir diff --git a/src/Stack/Sig.hs b/src/Stack/Sig.hs --- a/src/Stack/Sig.hs +++ b/src/Stack/Sig.hs @@ -2,7 +2,7 @@ {-| Module : Stack.Sig Description : GPG Signatures for Stack -Copyright : (c) FPComplete.com, 2015 +Copyright : (c) 2015-2018, Stack contributors License : BSD3 Maintainer : Tim Dysinger Stability : experimental diff --git a/src/Stack/Sig/GPG.hs b/src/Stack/Sig/GPG.hs --- a/src/Stack/Sig/GPG.hs +++ b/src/Stack/Sig/GPG.hs @@ -5,7 +5,7 @@ {-| Module : Stack.Sig.GPG Description : GPG Functions -Copyright : (c) FPComplete.com, 2015 +Copyright : (c) 2015-2018, Stack contributors License : BSD3 Maintainer : Tim Dysinger Stability : experimental @@ -29,8 +29,8 @@ -- | Sign a file path with GPG, returning the @Signature@. gpgSign - :: (MonadIO m, MonadLogger m, MonadThrow m) - => Path Abs File -> m Signature + :: HasLogFunc env + => Path Abs File -> RIO env Signature gpgSign path = do gpgWarnTTY (_hIn,hOut,hErr,process) <- @@ -97,7 +97,7 @@ -- | `man gpg-agent` shows that you need GPG_TTY environment variable set to -- properly deal with interactions with gpg-agent. (Doesn't apply to Windows -- though) -gpgWarnTTY :: (MonadIO m, MonadLogger m) => m () +gpgWarnTTY :: HasLogFunc env => RIO env () gpgWarnTTY = unless ("ming" `isPrefixOf` os) diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -7,7 +7,7 @@ {-| Module : Stack.Sig.Sign Description : Signing Packages -Copyright : (c) FPComplete.com, 2015 +Copyright : (c) 2015-2018, Stack contributors License : BSD3 Maintainer : Tim Dysinger Stability : experimental @@ -21,10 +21,9 @@ import Stack.Prelude import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as L -import qualified Data.Text as T import Network.HTTP.Client (RequestBody (RequestBodyBS)) import Network.HTTP.Download -import Network.HTTP.Simple +import Network.HTTP.Simple (setRequestMethod, setRequestBody, getResponseStatusCode) import Network.HTTP.Types (methodPut) import Path import Stack.Package @@ -36,12 +35,8 @@ -- | Sign a haskell package with the given url of the signature -- service and a path to a tarball. sign -#if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) -#else - :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) -#endif - => String -> Path Abs File -> m Signature + :: HasLogFunc env + => String -> Path Abs File -> RIO env Signature sign url filePath = withRunInIO $ \run -> withSystemTempDir @@ -82,12 +77,8 @@ -- function will write the bytes to the path in a temp dir and sign -- the tarball with GPG. signTarBytes -#if __GLASGOW_HASKELL__ < 710 - :: (Applicative m, MonadUnliftIO m, MonadLogger m, MonadThrow m) -#else - :: (MonadUnliftIO m, MonadLogger m, MonadThrow m) -#endif - => String -> Path Rel File -> L.ByteString -> m Signature + :: HasLogFunc env + => String -> Path Rel File -> L.ByteString -> RIO env Signature signTarBytes url tarPath bs = withSystemTempDir "stack" @@ -99,8 +90,8 @@ -- | Sign a haskell package given the url to the signature service, a -- @PackageIdentifier@ and a file path to the package on disk. signPackage - :: (MonadIO m, MonadLogger m, MonadThrow m) - => String -> PackageIdentifier -> Path Abs File -> m Signature + :: HasLogFunc env + => String -> PackageIdentifier -> Path Abs File -> RIO env Signature signPackage url pkg filePath = do sig@(Signature signature) <- gpgSign filePath let (PackageIdentifier name version) = pkg @@ -116,5 +107,5 @@ when (getResponseStatusCode res /= 200) (throwM (GPGSignException "unable to sign & upload package")) - logInfo ("Signature uploaded to " <> T.pack fullUrl) + logInfo ("Signature uploaded to " <> fromString fullUrl) return sig diff --git a/src/Stack/Snapshot.hs b/src/Stack/Snapshot.hs --- a/src/Stack/Snapshot.hs +++ b/src/Stack/Snapshot.hs @@ -21,7 +21,7 @@ , calculatePackagePromotion ) where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Control.Monad.State.Strict (get, put, StateT, execStateT) import Crypto.Hash.Conduit (hashFile) import Data.Aeson (withObject, (.!=), (.:), (.:?), Value (Object)) @@ -32,6 +32,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Time (toGregorian) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Yaml (decodeFileEither, ParseException (AesonException)) @@ -44,10 +45,11 @@ import qualified Distribution.Version as C import Network.HTTP.Client (Request) import Network.HTTP.Download +import qualified RIO +import Network.URI (isURI) import Path import Path.IO import Stack.Constants -import Stack.Fetch import Stack.Package import Stack.PackageDump import Stack.PackageLocation @@ -63,6 +65,7 @@ import Stack.Types.Compiler import Stack.Types.Resolver import qualified System.Directory as Dir +import qualified System.FilePath as FilePath type SinglePackageLocation = PackageLocationIndex FilePath @@ -74,6 +77,7 @@ | NeedResolverOrCompiler !Text | MissingPackages !(Set PackageName) | CustomResolverException !Text !(Either Request FilePath) !ParseException + | InvalidStackageException !SnapName !String deriving Typeable instance Exception SnapshotException instance Show SnapshotException where @@ -123,18 +127,28 @@ show (CustomResolverException url loc e) = concat [ "Unable to load custom resolver " , T.unpack url - , " from location\n" - , show loc + , " from " + , case loc of + Left _req -> "HTTP request" + Right fp -> "local file:\n " ++ fp , "\nException: " - , show e + , case e of + AesonException s -> s + _ -> show e ] + show (InvalidStackageException snapName e) = concat + [ "Unable to parse Stackage snapshot " + , T.unpack (renderSnapName snapName) + , ": " + , e + ] -- | Convert a 'Resolver' into a 'SnapshotDef' loadResolver :: forall env. HasConfig env => Resolver -> RIO env SnapshotDef -loadResolver (ResolverSnapshot name) = do +loadResolver (ResolverStackage name) = do stackage <- view stackRootL file' <- parseRelFile $ T.unpack file cachePath <- (buildPlanCacheDir stackage ) <$> parseRelFile (T.unpack (renderSnapName name <> ".cache")) @@ -145,23 +159,25 @@ Left e -> throwIO e Right value -> case parseEither parseStackageSnapshot value of - Left s -> throwIO $ AesonException s + Left s -> throwIO $ InvalidStackageException name s Right x -> return x - logDebug $ "Decoding build plan from: " <> T.pack (toFilePath fp) + logDebug $ "Decoding build plan from: " <> fromString (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) + logDebug $ + "Decoding Stackage snapshot definition from file failed: " <> + displayShow 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 + logSticky $ "Downloading " <> RIO.display name <> " build plan ..." + logDebug $ "Downloading build plan from: " <> RIO.display url wasDownloaded <- redownload req fp if wasDownloaded - then logStickyDone $ "Downloaded " <> renderSnapName name <> " build plan." - else logStickyDone $ "Skipped download of " <> renderSnapName name <> " because its the stored entity tag matches the server version" + then logStickyDone $ "Downloaded " <> RIO.display name <> " build plan." + else logStickyDone $ "Skipped download of " <> RIO.display name <> " because its the stored entity tag matches the server version" tryDecode >>= either throwM return where @@ -197,7 +213,7 @@ -- Not dropping any packages in a Stackage snapshot let sdDropPackages = Set.empty - let sdResolver = ResolverSnapshot name + let sdResolver = ResolverStackage name sdResolverName = renderSnapName name return SnapshotDef {..} @@ -240,7 +256,7 @@ , sdGlobalHints = Map.empty } loadResolver (ResolverCustom url loc) = do - logDebug $ "Loading " <> url <> " build plan from " <> T.pack (show loc) + logDebug $ "Loading " <> RIO.display url <> " build plan from " <> displayShow loc case loc of Left req -> download' req >>= load . toFilePath Right fp -> load fp @@ -260,24 +276,36 @@ load :: FilePath -> RIO env SnapshotDef load fp = do + let resolveLocalArchives sd = sd { + sdLocations = resolveLocalArchive <$> sdLocations sd + } + resolveLocalArchive (PLOther (PLArchive archive)) = + PLOther $ PLArchive $ archive { + archiveUrl = T.pack $ resolveLocalFilePath (T.unpack $ archiveUrl archive) + } + resolveLocalArchive pl = pl + resolveLocalFilePath path = + if isURI path || FilePath.isAbsolute path + then path + else FilePath.dropFileName fp FilePath. FilePath.normalise path + WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <- liftIO (decodeFileEither fp) >>= either (throwM . CustomResolverException url loc) - (either (throwM . AesonException) return . parseEither parseCustom) + (either (throwM . CustomResolverException url loc . AesonException) return . parseEither parseCustom) logJSONWarnings (T.unpack url) warnings - forM_ (sdLocations sd0) $ \loc' -> case loc' of PLOther (PLFilePath _) -> throwM $ FilepathInCustomSnapshot url _ -> return () - + let sd0' = resolveLocalArchives sd0 -- 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. mdir <- case loc of Left _ -> return Nothing - Right fp' -> (Just . parent) <$> liftIO (Dir.canonicalizePath fp' >>= parseAbsFile) + Right fp' -> Just . parent <$> liftIO (Dir.canonicalizePath fp' >>= parseAbsFile) -- Deal with the dual nature of the compiler key, which either -- means "use this compiler" or "override the compiler in the @@ -306,11 +334,11 @@ let hash' :: SnapshotHash hash' = combineHash rawHash $ case sdResolver parent' of - ResolverSnapshot snapName -> snapNameToHash snapName + ResolverStackage snapName -> snapNameToHash snapName ResolverCustom _ parentHash -> parentHash - ResolverCompiler _ -> error "loadResolver: Receieved ResolverCompiler in impossible location" + ResolverCompiler _ -> error "loadResolver: Received ResolverCompiler in impossible location" return (Right parent', hash') - return $ overrideCompiler sd0 + return $ overrideCompiler sd0' { sdParent = parent' , sdResolver = ResolverCustom url hash' } @@ -321,7 +349,7 @@ parseCustom :: Value -> Parser (WithJSONWarnings (SnapshotDef, Maybe (ResolverWith ()), Maybe (CompilerVersion 'CVWanted))) parseCustom = withObjectWarnings "CustomSnapshot" $ \o -> (,,) - <$> (SnapshotDef (Left (error "loadResolver")) (ResolverSnapshot (LTS 0 0)) + <$> (SnapshotDef (Left (error "loadResolver")) (ResolverStackage (LTS 0 0)) <$> (o ..: "name") <*> jsonSubWarningsT (o ..:? "packages" ..!= []) <*> o ..:? "drop-packages" ..!= Set.empty @@ -346,18 +374,7 @@ -> Path Abs Dir -- ^ project root, used for checking out necessary files -> SnapshotDef -> RIO env LoadedSnapshot -loadSnapshot mcompiler root sd = withCabalLoader $ \loader -> loadSnapshot' loader mcompiler root sd - --- | Fully load up a 'SnapshotDef' into a 'LoadedSnapshot' -loadSnapshot' - :: forall env. - (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) -- ^ load a cabal file's contents from the index - -> 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 - -> RIO env LoadedSnapshot -loadSnapshot' loadFromIndex mcompiler root = +loadSnapshot mcompiler root = start where start (snapshotDefFixes -> sd) = do @@ -381,18 +398,18 @@ Right sd' -> start sd' gpds <- - (concat <$> mapM (parseMultiCabalFilesIndex loadFromIndex root) (sdLocations sd)) + (concat <$> mapM (parseMultiCabalFilesIndex root) (sdLocations sd)) `onException` do logError "Unable to load cabal files for snapshot" case sdResolver sd of - ResolverSnapshot name -> do + ResolverStackage name -> do stackRoot <- view stackRootL file <- parseRelFile $ T.unpack $ renderSnapName name <> ".yaml" let fp = buildPlanDir stackRoot file liftIO $ ignoringAbsence $ removeFile fp logError "" logError "----" - logError $ "Deleting cached snapshot file: " <> T.pack (toFilePath fp) + logError $ "Deleting cached snapshot file: " <> fromString (toFilePath fp) logError "Recommendation: try running again. If this fails again, open an upstream issue at:" logError $ case name of @@ -403,7 +420,7 @@ _ -> return () (globals, snapshot, locals) <- - calculatePackagePromotion loadFromIndex root ls0 + calculatePackagePromotion root ls0 (map (\(x, y) -> (x, y, ())) gpds) (sdFlags sd) (sdHidden sd) (sdGhcOptions sd) (sdDropPackages sd) @@ -424,8 +441,7 @@ calculatePackagePromotion :: forall env localLocation. (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) -- ^ load from index - -> Path Abs Dir -- ^ project root + => 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 @@ -438,7 +454,7 @@ , Map PackageName (LoadedPackageInfo (SinglePackageLocation, Maybe localLocation)) -- new locals ) calculatePackagePromotion - loadFromIndex root (LoadedSnapshot compilerVersion globals0 parentPackages0) + root (LoadedSnapshot compilerVersion globals0 parentPackages0) gpds flags0 hides0 options0 drops0 = do platform <- view platformL @@ -500,7 +516,7 @@ -- ... so recalculate based on new values upgraded <- fmap Map.fromList - $ mapM (recalculate loadFromIndex root compilerVersion flags hide ghcOptions) + $ mapM (recalculate root compilerVersion flags hide ghcOptions) $ Map.toList allToUpgrade -- Could be nice to check snapshot early... but disabling @@ -526,22 +542,21 @@ -- hide values, and GHC options. recalculate :: forall env. (HasConfig env, HasGHCVariant env) - => (PackageIdentifierRevision -> IO ByteString) - -> Path Abs Dir -- ^ root + => Path Abs Dir -- ^ root -> CompilerVersion 'CVActual -> Map PackageName (Map FlagName Bool) -> Map PackageName Bool -- ^ hide? -> Map PackageName [Text] -- ^ GHC options -> (PackageName, LoadedPackageInfo SinglePackageLocation) -> RIO env (PackageName, LoadedPackageInfo SinglePackageLocation) -recalculate loadFromIndex root compilerVersion allFlags allHide allOptions (name, lpi0) = do +recalculate 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 <- parseSingleCabalFileIndex loadFromIndex root loc + gpd <- parseSingleCabalFileIndex root 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" @@ -606,8 +621,7 @@ => CompilerVersion 'CVActual -> RIO env LoadedSnapshot loadCompiler cv = do - menv <- getMinimalEnvOverride - m <- ghcPkgDump menv (whichCompiler cv) [] + m <- ghcPkgDump (whichCompiler cv) [] (conduitDumpPackage .| CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)) return LoadedSnapshot { lsCompilerVersion = cv @@ -686,10 +700,9 @@ where PackageIdentifier name _version = fromCabalPackageIdentifier $ C.package $ C.packageDescription gpd --- | Some hard-coded fixes for build plans, hopefully to be irrelevant over --- time. +-- | Some hard-coded fixes for build plans, only for hysterical raisins. snapshotDefFixes :: SnapshotDef -> SnapshotDef -snapshotDefFixes sd | isStackage (sdResolver sd) = sd +snapshotDefFixes sd | isOldStackage (sdResolver sd) = sd { sdFlags = Map.unionWith Map.union overrides $ sdFlags sd } where @@ -698,8 +711,12 @@ , ($(mkPackageName "yaml"), Map.singleton $(mkFlagName "system-libyaml") False) ] - isStackage (ResolverSnapshot _) = True - isStackage _ = False + -- Only apply this hack to older Stackage snapshots. In + -- particular, nightly-2018-03-13 did not contain these two + -- packages. + isOldStackage (ResolverStackage (LTS major _)) = major < 11 + isOldStackage (ResolverStackage (Nightly (toGregorian -> (year, _, _)))) = year < 2018 + isOldStackage _ = False snapshotDefFixes sd = sd -- | Convert a global 'LoadedPackageInfo' to a snapshot one by @@ -709,9 +726,16 @@ { lpiLocation = PLIndex (PackageIdentifierRevision (PackageIdentifier name (lpiVersion lpi)) CFILatest) } --- | 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. +-- | Split the packages into those which have their dependencies met, +-- and those that don't. The first argument is packages that are known +-- to be available for use as a dependency. The second argument is the +-- packages to check. +-- +-- This works by repeatedly iterating through the list of input +-- packages, adding any that have their dependencies satisfied to a map +-- (eventually this set is the fst of the result tuple). Once an +-- iteration completes without adding anything to this set, it knows it +-- has found everything that has its dependencies met, and exits. splitUnmetDeps :: Map PackageName Version -- ^ extra dependencies available -> Map PackageName (LoadedPackageInfo loc) -> ( Map PackageName (LoadedPackageInfo loc) diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -19,36 +19,37 @@ , parseCabalOutputLine ) where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Data.Aeson.Extended (object, (.=), toJSON) import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as BL import Data.Char (isSpace) +import Data.Conduit.Process.Typed (eceStderr) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet -import Data.List ( (\\), isSuffixOf, intercalate - , minimumBy, isPrefixOf) +import Data.List ( (\\), isSuffixOf + , minimumBy, isPrefixOf + , intersperse) import Data.List.Extra (groupSortOn) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Tuple (swap) import qualified Data.Yaml as Yaml import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Text as C -import Lens.Micro (set) import Path import Path.Find (findFiles) import Path.IO hiding (findExecutable, findFiles, withSystemTempDir) +import qualified RIO import Stack.Build.Target (gpdVersion) import Stack.BuildPlan import Stack.Config (getLocalPackages, loadConfigYaml) import Stack.Constants (stackDotYaml, wiredInPackages) import Stack.Package (readPackageUnresolvedDir, gpdPackageName) +import Stack.PackageIndex import Stack.PrettyPrint import Stack.Setup import Stack.Setup.Installed @@ -61,11 +62,10 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Resolver -import Stack.Types.Runner import Stack.Types.Version import qualified System.Directory as D import qualified System.FilePath as FP -import System.Process.Read +import RIO.Process import Text.Regex.Applicative.Text (match, sym, psym, anySym, few) import qualified Data.Text.Normalize as T ( normalize , NormalizationMode(NFC) ) @@ -111,12 +111,12 @@ toConstraintArgs (flagConstraints constraintType) ++ fmap toFilePath cabalfps - menv <- getMinimalEnvOverride - catch (liftM Right (readProcessStdout (Just tmpdir) menv "cabal" args)) - (\ex -> case ex of - ProcessFailed _ _ _ err -> return $ Left err - _ -> throwM ex) - >>= either parseCabalErrors parseCabalOutput + try ( withWorkingDir (toFilePath tmpdir) + $ proc "cabal" args readProcessStdout_ + ) + >>= either + (parseCabalErrors . eceStderr) + (parseCabalOutput . BL.toStrict) where errCheck = T.isInfixOf "Could not resolve dependencies" @@ -129,11 +129,11 @@ parseCabalErrors err = do let errExit e = error $ "Could not parse cabal-install errors:\n\n" ++ cabalBuildErrMsg (T.unpack e) - msg = LT.toStrict $ decodeUtf8With lenientDecode err + msg = decodeUtf8With lenientDecode $ toStrictBytes err if errCheck msg then do logInfo "Attempt failed.\n" - logInfo $ cabalBuildErrMsg msg + logInfo $ RIO.display $ cabalBuildErrMsg msg let pkgs = parseConflictingPkgs msg mPkgNames = map (C.simpleParse . T.unpack) pkgs pkgNames = map (fromCabalPackageName . C.pkgName) @@ -141,7 +141,7 @@ when (any isNothing mPkgNames) $ do logInfo $ "*** Only some package names could be parsed: " <> - T.pack (intercalate ", " (map show pkgNames)) + mconcat (intersperse ", " (map displayShow pkgNames)) error $ T.unpack $ "*** User packages involved in cabal failure: " <> T.intercalate ", " (parseConflictingPkgs msg) @@ -166,7 +166,7 @@ let ls = drop 1 $ dropWhile (not . T.isPrefixOf "In order, ") $ linesNoCR - $ decodeUtf8 bs + $ decodeUtf8With lenientDecode bs (errs, pairs) = partitionEithers $ map parseCabalOutputLine ls if null errs then return $ Right (Map.fromList pairs) @@ -226,7 +226,7 @@ -> Map PackageName Version -- ^ constraints -> RIO env [Text] getCabalConfig dir constraintType constraints = do - indices <- view $ configL.to configPackageIndices + indices <- view $ cabalLoaderL.to clIndices remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir return $ cache : remotes ++ map goConstraint (Map.toList constraints) @@ -300,15 +300,14 @@ -> (CompilerVersion 'CVActual -> RIO env a) -> RIO env a setupCabalEnv compiler inner = do - mpaths <- setupCompiler compiler - menv0 <- getMinimalEnvOverride - envMap <- removeHaskellEnvVars - <$> augmentPathMap (maybe [] edBins mpaths) - (unEnvOverride menv0) - platform <- view platformL - menv <- mkEnvOverride platform envMap - - mcabal <- getCabalInstallVersion menv + mpaths <- setupCompiler compiler + menv0 <- view processContextL + envMap <- either throwM (return . removeHaskellEnvVars) + $ augmentPathMap (toFilePath <$> maybe [] edBins mpaths) + (view envVarsL menv0) + menv <- mkProcessContext envMap + withProcessContext menv $ do + mcabal <- getCabalInstallVersion case mcabal of Nothing -> throwM SolverMissingCabalInstall Just version @@ -323,16 +322,15 @@ ") is newer than stack has been tested with. If you run into difficulties, consider downgrading." <> line | otherwise -> return () - mver <- getSystemCompiler menv (whichCompiler compiler) + mver <- getSystemCompiler (whichCompiler compiler) version <- case mver of Just (version, _) -> do - logInfo $ "Using compiler: " <> compilerVersionText version + logInfo $ "Using compiler: " <> RIO.display version return version Nothing -> error "Failed to determine compiler version. \ \This is most likely a bug." - env <- set envOverrideL (const (return menv)) <$> ask - runRIO env (inner version) + inner 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 @@ -378,7 +376,7 @@ solveResolverSpec stackYaml cabalDirs (sd, srcConstraints, extraConstraints) = do - logInfo $ "Using resolver: " <> sdResolverName sd + logInfo $ "Using resolver: " <> RIO.display (sdResolverName sd) let wantedCompilerVersion = sdWantedCompilerVersion sd setupCabalEnv wantedCompilerVersion $ \compilerVersion -> do (compilerVer, snapConstraints) <- getResolverConstraints (Just compilerVersion) stackYaml sd @@ -403,12 +401,12 @@ logInfo "Asking cabal to calculate a build plan..." unless (Map.null depOnlyConstraints) - (logInfo $ "Trying with " <> srcNames <> " as hard constraints...") + (logInfo $ "Trying with " <> RIO.display srcNames <> " as hard constraints...") eresult <- solver Constraint eresult' <- case eresult of Left _ | not (Map.null depOnlyConstraints) -> do - logInfo $ "Retrying with " <> srcNames <> " as preferences..." + logInfo $ "Retrying with " <> RIO.display srcNames <> " as preferences..." solver Preference _ -> return eresult @@ -455,7 +453,7 @@ <> showItems (map show (Map.toList bothVers)) logInfo $ "Successfully determined a build plan with " - <> T.pack (show $ Map.size external) + <> displayShow (Map.size external) <> " external dependencies." return $ Right (srcs, external) @@ -501,10 +499,10 @@ -- package.yaml. Subdirectories can be included depending on the -- @recurse@ parameter. findCabalDirs - :: (MonadIO m, MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m, HasConfig env) - => Bool -> Path Abs Dir -> m (Set (Path Abs Dir)) + :: HasConfig env + => Bool -> Path Abs Dir -> RIO env (Set (Path Abs Dir)) findCabalDirs recurse dir = - (Set.fromList . map parent) + Set.fromList . map parent <$> liftIO (findFiles dir isHpackOrCabal subdirFilter) where subdirFilter subdir = recurse && not (isIgnored subdir) @@ -543,7 +541,7 @@ relpaths <- mapM prettyPath cabaldirs logInfo "Using cabal packages:" - logInfo $ T.pack (formatGroup relpaths) + logInfo $ formatGroup relpaths packages <- map (\(x, y) -> (y, x)) <$> mapM (flip readPackageUnresolvedDir True) @@ -566,7 +564,7 @@ error $ "Package name as defined in the .cabal file must match the \ \.cabal file name.\n\ \Please fix the following packages and try again:\n" - <> formatGroup rels + <> T.unpack (utf8BuilderToText (formatGroup rels)) let dupGroups = filter ((> 1) . length) . groupSortOn (gpdPackageName . snd) @@ -581,11 +579,11 @@ when (dupIgnored /= []) $ do dups <- mapM (mapM (prettyPath. fst)) (dupGroups packages) - logWarn $ T.pack $ - "Following packages have duplicate package names:\n" - <> intercalate "\n" (map formatGroup dups) + logWarn $ + "Following packages have duplicate package names:\n" <> + mconcat (intersperse "\n" (map formatGroup dups)) case dupErrMsg of - Nothing -> logWarn $ T.pack $ + Nothing -> logWarn $ "Packages with duplicate names will be ignored.\n" <> "Packages in upper level directories will be preferred.\n" Just msg -> error msg @@ -594,15 +592,14 @@ $ map (\(file, gpd) -> (gpdPackageName gpd,(file, gpd))) unique , map fst dupIgnored) -formatGroup :: [String] -> String -formatGroup = concatMap (\path -> "- " <> path <> "\n") +formatGroup :: [String] -> Utf8Builder +formatGroup = foldMap (\path -> "- " <> fromString path <> "\n") reportMissingCabalFiles - :: (MonadIO m, MonadUnliftIO m, MonadThrow m, MonadLogger m, - HasRunner env, MonadReader env m, HasConfig env) + :: HasConfig env => [Path Abs File] -- ^ Directories to scan -> Bool -- ^ Whether to scan sub-directories - -> m () + -> RIO env () reportMissingCabalFiles cabalfps includeSubdirs = do allCabalDirs <- findCabalDirs includeSubdirs =<< getCurrentDir @@ -611,7 +608,7 @@ $ allCabalDirs `Set.difference` Set.fromList (map parent cabalfps) unless (null relpaths) $ do logWarn "The following packages are missing from the config:" - logWarn $ T.pack (formatGroup relpaths) + logWarn $ formatGroup relpaths -- TODO Currently solver uses a stack.yaml in the parent chain when there is -- no stack.yaml in the current directory. It should instead look for a @@ -632,7 +629,7 @@ let stackYaml = bcStackYaml bconfig relStackYaml <- prettyPath stackYaml - logInfo $ "Using configuration file: " <> T.pack relStackYaml + logInfo $ "Using configuration file: " <> fromString relStackYaml lp <- getLocalPackages let packages = lpProject lp let noPkgMsg = "No cabal packages found in " <> relStackYaml <> @@ -665,12 +662,12 @@ resultSpecs <- case resolverResult of BuildPlanCheckOk flags -> return $ Just (mergeConstraints oldSrcs flags, Map.empty) - BuildPlanCheckPartial {} -> do - eres <- solveResolverSpec stackYaml cabalDirs + BuildPlanCheckPartial {} -> + either (const Nothing) Just <$> + solveResolverSpec stackYaml cabalDirs (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 (sdResolverName sd) (show resolverResult) @@ -701,7 +698,7 @@ if changed then do logInfo "" logInfo $ "The following changes will be made to " - <> T.pack relStackYaml <> ":" + <> fromString relStackYaml <> ":" printResolver (fmap void mOldResolver) (void resolver) @@ -714,12 +711,12 @@ -- TODO backup the old config file if modStackYaml then do writeStackYaml stackYaml resolver versions flags - logInfo $ "Updated " <> T.pack relStackYaml + logInfo $ "Updated " <> fromString relStackYaml else do - logInfo $ "To automatically update " <> T.pack relStackYaml + logInfo $ "To automatically update " <> fromString relStackYaml <> ", rerun with '--update-config'" else - logInfo $ "No changes needed to " <> T.pack relStackYaml + logInfo $ "No changes needed to " <> fromString relStackYaml where indentLines t = T.unlines $ fmap (" " <>) (T.lines t) @@ -727,23 +724,22 @@ printResolver mOldRes res = do forM_ mOldRes $ \oldRes -> when (res /= oldRes) $ do - logInfo $ T.concat - [ "* Resolver changes from " - , resolverRawName oldRes - , " to " - , resolverRawName res - ] + logInfo $ + "* Resolver changes from " <> + RIO.display (resolverRawName oldRes) <> + " to " <> + RIO.display (resolverRawName res) printFlags fl msg = do unless (Map.null fl) $ do - logInfo $ T.pack msg - logInfo $ indentLines $ decodeUtf8 $ Yaml.encode + logInfo $ fromString msg + logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode $ object ["flags" .= fl] printDeps deps msg = do unless (Map.null deps) $ do - logInfo $ T.pack msg - logInfo $ indentLines $ decodeUtf8 $ Yaml.encode $ object + logInfo $ fromString msg + logInfo $ RIO.display $ indentLines $ decodeUtf8 $ Yaml.encode $ object ["extra-deps" .= map fromTuple (Map.toList deps)] writeStackYaml path res deps fl = do @@ -786,7 +782,7 @@ let forNonSnapshot inner = setupCabalEnv (sdWantedCompilerVersion sd) (inner . Just) runner = case sdResolver sd of - ResolverSnapshot _ -> ($ Nothing) + ResolverStackage _ -> ($ Nothing) ResolverCompiler _ -> forNonSnapshot ResolverCustom _ _ -> forNonSnapshot diff --git a/src/Stack/StaticBytes.hs b/src/Stack/StaticBytes.hs --- a/src/Stack/StaticBytes.hs +++ b/src/Stack/StaticBytes.hs @@ -114,9 +114,8 @@ lengthD = VP.length fromWordsD len words0 = unsafePerformIO $ do ba <- BA.newByteArray len - let loop _ [] = do - ba' <- BA.unsafeFreezeByteArray ba - return $ VP.Vector 0 len ba' + let loop _ [] = + VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba loop i (w:ws) = do BA.writeByteArray ba i w loop (i + 1) ws diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -74,13 +74,14 @@ import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version import System.Exit (ExitCode (ExitFailure)) import System.FilePath (pathSeparator) -import System.Process.Log (showProcessArgDebug) +import RIO.Process (showProcessArgDebug) ---------------------------------------------- -- Exceptions @@ -604,7 +605,6 @@ , map ("--extra-include-dirs=" ++) (Set.toList (configExtraIncludeDirs config)) , map ("--extra-lib-dirs=" ++) (Set.toList (configExtraLibDirs config)) , maybe [] (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) (configOverrideGccPath config) - , hpackOptions (configOverrideHpack config) , ["--ghcjs" | wc == Ghcjs] , ["--exact-configuration" | useExactConf] ] @@ -628,9 +628,6 @@ depOptions = map (uncurry toDepOption) $ Map.toList deps where toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18 - - hpackOptions HpackBundled = [] - hpackOptions (HpackCommand cmd) = ["--with-hpack=" ++ cmd] toDepOption1_22 ident gid = concat [ "--dependency=" diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -102,7 +102,7 @@ instance NFData SnapshotDef snapshotDefVC :: VersionConfig SnapshotDef -snapshotDefVC = storeVersionConfig "sd-v1" "tnwWSSLerZ2XeR6XpVwj5Uh0eF4=" +snapshotDefVC = storeVersionConfig "sd-v1" "CKo7nln8EXkw07Gq-4ATxszNZiE=" -- | A relative file path including a unique string for the given -- snapshot. @@ -110,7 +110,7 @@ sdRawPathName sd = T.unpack $ go $ sdResolver sd where - go (ResolverSnapshot name) = renderSnapName name + go (ResolverStackage name) = renderSnapName name go (ResolverCompiler version) = compilerVersionText version go (ResolverCustom _ hash) = "custom-" <> sdResolverName sd <> "-" <> trimmedSnapshotHash hash @@ -229,7 +229,7 @@ instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocationIndex subdirs)) where parseJSON v - = ((noJSONWarnings . PLIndex) <$> parseJSON v) + = (noJSONWarnings . PLIndex <$> parseJSON v) <|> (fmap PLOther <$> parseJSON v) instance subdirs ~ Subdirs => FromJSON (WithJSONWarnings (PackageLocation subdirs)) where @@ -237,6 +237,7 @@ = (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> repo v <|> archiveObject v + <|> github v where file t = pure $ PLFilePath $ T.unpack t http t = @@ -269,6 +270,26 @@ , archiveHash = msha' } + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + subdirs <- o ..:? "subdirs" ..!= DefaultSubdirs + return $ PLArchive Archive + { archiveUrl = "https://github.com/" <> ghRepo <> "/archive/" <> commit <> ".tar.gz" + , archiveSubdirs = subdirs + , archiveHash = Nothing + } + +-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains +-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". +newtype GitHubRepo = GitHubRepo Text + +instance FromJSON GitHubRepo where + parseJSON = withText "GitHubRepo" $ \s -> do + case T.split (== '/') s of + [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) + _ -> fail "expecting \"user/repo\"" + -- | Name of an executable. newtype ExeName = ExeName { unExeName :: Text } deriving (Show, Eq, Ord, Hashable, IsString, Generic, Store, NFData, Data, Typeable) @@ -342,12 +363,15 @@ instance Store DepInfo instance NFData DepInfo -instance Monoid DepInfo where - mempty = DepInfo mempty (fromVersionRange C.anyVersion) - DepInfo a x `mappend` DepInfo b y = DepInfo +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo (mappend a b) (intersectVersionIntervals x y) +instance Monoid DepInfo where + mempty = DepInfo mempty (fromVersionRange C.anyVersion) + mappend = (<>) + data Component = CompLibrary | CompExecutable | CompTestSuite @@ -369,10 +393,13 @@ instance Store ModuleInfo instance NFData ModuleInfo +instance Semigroup ModuleInfo where + ModuleInfo x <> ModuleInfo y = + ModuleInfo (Map.unionWith Set.union x y) + instance Monoid ModuleInfo where mempty = ModuleInfo mempty - mappend (ModuleInfo x) (ModuleInfo y) = - ModuleInfo (Map.unionWith Set.union x y) + mappend = (<>) moduleInfoVC :: VersionConfig ModuleInfo moduleInfoVC = storeVersionConfig "mi-v2" "8ImAfrwMVmqoSoEpt85pLvFeV3s=" diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -31,10 +31,6 @@ -- -- Note that despite having this datatype, stack isn't in a hurry to -- support compilers other than GHC. --- --- NOTE: updating this will change its binary serialization. The --- version number in the 'BinarySchema' instance for 'MiniBuildPlan' --- should be updated. data CompilerVersion (cvType :: CVType) = GhcVersion {-# UNPACK #-} !Version | GhcjsVersion @@ -43,6 +39,8 @@ deriving (Generic, Show, Eq, Ord, Data, Typeable) instance Store (CompilerVersion a) instance NFData (CompilerVersion a) +instance Display (CompilerVersion a) where + display = display . compilerVersionText instance ToJSON (CompilerVersion a) where toJSON = toJSON . compilerVersionText instance FromJSON (CompilerVersion a) where diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -35,7 +35,6 @@ ,HasConfig(..) ,askLatestSnapshotUrl ,explicitSetupDeps - ,getMinimalEnvOverride -- ** BuildConfig & HasBuildConfig ,BuildConfig(..) ,LocalPackages(..) @@ -44,7 +43,6 @@ ,lpvName ,lpvVersion ,lpvComponents - ,NamedComponent(..) ,stackYamlL ,projectRootL ,HasBuildConfig(..) @@ -77,6 +75,8 @@ -- ** EnvSettings ,EnvSettings(..) ,minimalEnvSettings + ,defaultEnvSettings + ,plainEnvSettings -- ** GlobalOpts & GlobalOptsMonoid ,GlobalOpts(..) ,GlobalOptsMonoid(..) @@ -90,14 +90,6 @@ ,PackageIndex(..) ,IndexName(..) ,indexNameText - -- Config fields - ,configPackageIndex - ,configPackageIndexOld - ,configPackageIndexCache - ,configPackageIndexCacheOld - ,configPackageIndexGz - ,configPackageIndexRoot - ,configPackageTarball -- ** Project & ProjectAndConfigMonoid ,Project(..) ,ProjectAndConfigMonoid(..) @@ -133,6 +125,7 @@ ,platformGhcVerOnlyRelDir ,useShaPathOnWindows ,shaPath + ,shaPathForBytes ,workDirL -- * Command-specific types -- ** Eval @@ -163,13 +156,13 @@ ,buildOptsMonoidInstallExesL ,buildOptsHaddockL ,globalOptsBuildOptsMonoidL - ,packageIndicesL ,stackRootL ,configUrlsL ,cabalVersionL ,whichCompilerL - ,envOverrideL + ,envOverrideSettingsL ,loadedSnapshotL + ,globalHintsL ,shouldForceGhcColorFlag ,appropriateGhcColorFlag -- * Lens reexport @@ -213,12 +206,14 @@ import Path import qualified Paths_stack as Meta import Stack.Constants +import Stack.PackageIndex (HasCabalLoader (..), CabalLoader (clStackRoot)) import Stack.Types.BuildPlan import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Docker import Stack.Types.FlagName import Stack.Types.Image +import Stack.Types.NamedComponent import Stack.Types.Nix import Stack.Types.PackageIdentifier import Stack.Types.PackageIndex @@ -230,16 +225,14 @@ import Stack.Types.Version import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) -import System.Process.Read (EnvOverride, findExecutable) +import RIO.Process (ProcessContext, HasProcessContext (..), findExecutable) -- Re-exports import Stack.Types.Config.Build as X -- | The top-level Stackage configuration. data Config = - Config {configStackRoot :: !(Path Abs Dir) - -- ^ ~/.stack more often than not - ,configWorkDir :: !(Path Rel Dir) + Config {configWorkDir :: !(Path Rel Dir) -- ^ this allows to override .stack-work directory ,configUserConfigPath :: !(Path Abs File) -- ^ Path to user configuration file (usually ~/.stack/config.yaml) @@ -249,14 +242,12 @@ -- ^ Docker configuration ,configNix :: !NixOpts -- ^ Execution environment (e.g nix-shell) configuration - ,configEnvOverride :: !(EnvSettings -> IO EnvOverride) + ,configProcessContextSettings :: !(EnvSettings -> IO ProcessContext) -- ^ Environment variables to be passed to external tools ,configLocalProgramsBase :: !(Path Abs Dir) -- ^ Non-platform-specific path containing local installations ,configLocalPrograms :: !(Path Abs Dir) -- ^ Path containing local installations (mainly GHC) - ,configConnectionCount :: !Int - -- ^ How many concurrent connections are allowed when downloading ,configHideTHLoading :: !Bool -- ^ Hide the Template Haskell "Loading package ..." messages from the -- console @@ -276,21 +267,6 @@ -- e.g. The latest snapshot file. -- A build plan name (e.g. lts5.9.yaml) is appended when downloading -- the build plan actually. - ,configPackageIndices :: ![PackageIndex] - -- ^ Information on package indices. This is left biased, meaning that - -- packages in an earlier index will shadow those in a later index. - -- - -- Warning: if you override packages in an index vs what's available - -- upstream, you may correct your compiled snapshots, as different - -- projects may have different definitions of what pkg-ver means! This - -- feature is primarily intended for adding local packages, not - -- overriding. Overriding is better accomplished by adding to your - -- list of packages. - -- - -- Note that indices specified in a later config file will override - -- previous indices, /not/ extend them. - -- - -- Using an assoc list instead of a Map to keep track of priority ,configSystemGHC :: !Bool -- ^ Should we use the system-installed GHC (on the PATH) if -- available? Can be overridden by command line options. @@ -349,8 +325,6 @@ ,configAllowDifferentUser :: !Bool -- ^ Allow users other than the stack root owner to use the stack -- installation. - ,configPackageCache :: !(IORef (Maybe (PackageCache PackageIndex))) - -- ^ In memory cache of hackage index. ,configDumpLogs :: !DumpLogs -- ^ Dump logs of local non-dependencies when doing a build. ,configMaybeProject :: !(Maybe (Project, Path Abs File)) @@ -362,10 +336,7 @@ ,configSaveHackageCreds :: !Bool -- ^ Should we save Hackage credentials to a file? ,configRunner :: !Runner - ,configIgnoreRevisionMismatch :: !Bool - -- ^ Ignore a revision mismatch when loading up cabal files, - -- and fall back to the latest revision. See: - -- + ,configCabalLoader :: !CabalLoader } data HpackExecutable @@ -489,9 +460,12 @@ , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml } deriving (Show, Generic) +instance Semigroup GlobalOptsMonoid where + (<>) = mappenddefault + instance Monoid GlobalOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Default logging level should be something useful but not crazy. defaultLogLevel :: LogLevel @@ -620,14 +594,6 @@ $ lpvGPD lpv in version --- | 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 = LoadConfig { lcConfig :: !Config @@ -715,7 +681,7 @@ data ConfigMonoid = ConfigMonoid { configMonoidStackRoot :: !(First (Path Abs Dir)) - -- ^ See: 'configStackRoot' + -- ^ See: 'clStackRoot' , configMonoidWorkDir :: !(First (Path Rel Dir)) -- ^ See: 'configWorkDir'. , configMonoidBuildOpts :: !BuildOptsMonoid @@ -733,7 +699,7 @@ , configMonoidUrls :: !UrlsMonoid -- ^ See: 'configUrls , configMonoidPackageIndices :: !(First [PackageIndex]) - -- ^ See: 'configPackageIndices' + -- ^ See: @picIndices@ , configMonoidSystemGHC :: !(First Bool) -- ^ See: 'configSystemGHC' ,configMonoidInstallGHC :: !(First Bool) @@ -809,9 +775,12 @@ } deriving (Show, Generic) +instance Semigroup ConfigMonoid where + (<>) = mappenddefault + instance Monoid ConfigMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) parseConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings ConfigMonoid) parseConfigMonoid = withObjectWarnings "ConfigMonoid" . parseConfigMonoidObject @@ -1095,7 +1064,7 @@ ) ] show (UnableToExtractArchive url file) = concat - [ "Archive extraction failed. We support tarballs and zip, couldn't handle the following URL, " + [ "Archive extraction failed. Tarballs and zip archives are supported, couldn't handle the following URL, " , T.unpack url, " downloaded to the file ", toFilePath $ filename file ] show (BadStackVersionException requiredRange) = concat @@ -1211,44 +1180,6 @@ askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text askLatestSnapshotUrl = view $ configL.to configUrls.to urlsLatestSnapshot --- | Root for a specific package index -configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir) -configPackageIndexRoot (IndexName name) = do - root <- view stackRootL - dir <- parseRelDir $ S8.unpack name - return (root $(mkRelDir "indices") dir) - --- | Location of the 01-index.cache file -configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexCache = liftM ( $(mkRelFile "01-index.cache")) . configPackageIndexRoot - --- | Location of the 00-index.cache file -configPackageIndexCacheOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexCacheOld = liftM ( $(mkRelFile "00-index.cache")) . configPackageIndexRoot - --- | Location of the 01-index.tar file -configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndex = liftM ( $(mkRelFile "01-index.tar")) . configPackageIndexRoot - --- | Location of the 00-index.tar file. This file is just a copy of --- the 01-index.tar file, provided for tools which still look for the --- 00-index.tar file. -configPackageIndexOld :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexOld = liftM ( $(mkRelFile "00-index.tar")) . configPackageIndexRoot - --- | Location of the 01-index.tar.gz file -configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File) -configPackageIndexGz = liftM ( $(mkRelFile "01-index.tar.gz")) . configPackageIndexRoot - --- | Location of a package tarball -configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File) -configPackageTarball iname ident = do - root <- configPackageIndexRoot iname - name <- parseRelDir $ packageNameString $ packageIdentifierName ident - ver <- parseRelDir $ versionString $ packageIdentifierVersion ident - base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz" - return (root $(mkRelDir "packages") name ver base) - -- | @".stack-work"@ workDirL :: HasConfig env => Lens' env (Path Rel Dir) workDirL = configL.lens configWorkDir (\x y -> x { configWorkDir = y }) @@ -1303,7 +1234,7 @@ compilerVersion <- envConfigCompilerVersion <$> view envConfigL compiler <- parseRelDir $ compilerVersionString compilerVersion return $ - configStackRoot config + view stackRootL config $(mkRelDir "compiler-tools") platform compiler @@ -1377,10 +1308,12 @@ #endif shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t) -shaPath +shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath + +shaPathForBytes :: (IsPath Rel t, MonadThrow m) => ByteString -> m (Path Rel t) +shaPathForBytes = parsePath . S8.unpack . S8.take 8 . Mem.convertToBase Mem.Base16 . hashWith SHA1 - . encodeUtf8 . T.pack . toFilePath -- TODO: Move something like this into the path package. Consider -- subsuming path-io's 'AnyPath'? @@ -1468,19 +1401,12 @@ => m (Bool -> [Path Abs Dir]) extraBinDirs = do deps <- installationRootDeps - local <- installationRootLocal + local' <- installationRootLocal tools <- bindirCompilerTools return $ \locals -> if locals - then [local bindirSuffix, deps bindirSuffix, tools] + then [local' bindirSuffix, deps bindirSuffix, tools] else [deps bindirSuffix, tools] --- | Get the minimal environment override, useful for just calling external --- processes like git or ghc -getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride -getMinimalEnvOverride = do - config' <- view configL - liftIO $ configEnvOverride config' minimalEnvSettings - minimalEnvSettings :: EnvSettings minimalEnvSettings = EnvSettings @@ -1491,6 +1417,32 @@ , esKeepGhcRts = False } +-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH. +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 +defaultEnvSettings :: EnvSettings +defaultEnvSettings = EnvSettings + { esIncludeLocals = True + , esIncludeGhcPackagePath = True + , esStackExe = True + , esLocaleUtf8 = False + , esKeepGhcRts = True + } + +-- | Environment settings which do not embellish the environment +-- +-- Note that this also passes through the GHCRTS environment variable. +-- See https://github.com/commercialhaskell/stack/issues/3444 +plainEnvSettings :: EnvSettings +plainEnvSettings = EnvSettings + { esIncludeLocals = False + , esIncludeGhcPackagePath = False + , esStackExe = False + , esLocaleUtf8 = False + , esKeepGhcRts = True + } + -- | Get the path for the given compiler ignoring any local binaries. -- -- https://github.com/commercialhaskell/stack/issues/1052 @@ -1501,8 +1453,11 @@ getCompilerPath wc = do config' <- view configL eoWithoutLocals <- liftIO $ - configEnvOverride config' minimalEnvSettings { esLocaleUtf8 = True } - join (findExecutable eoWithoutLocals (compilerExeName wc)) + configProcessContextSettings config' minimalEnvSettings { esLocaleUtf8 = True } + eres <- runRIO eoWithoutLocals $ findExecutable $ compilerExeName wc + case eres of + Left e -> throwM e + Right x -> parseAbsFile x data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid @@ -1730,6 +1685,16 @@ -- | For @siGHCs@ and @siGHCJSs@ fields maps are deeply merged. -- For all fields the values from the last @SetupInfo@ win. +instance Semigroup SetupInfo where + l <> r = + SetupInfo + { siSevenzExe = siSevenzExe r <|> siSevenzExe l + , siSevenzDll = siSevenzDll r <|> siSevenzDll l + , siMsys2 = siMsys2 r <> siMsys2 l + , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l) + , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l) + , siStack = Map.unionWith (<>) (siStack l) (siStack r) } + instance Monoid SetupInfo where mempty = SetupInfo @@ -1740,14 +1705,7 @@ , siGHCJSs = Map.empty , siStack = Map.empty } - mappend l r = - SetupInfo - { siSevenzExe = siSevenzExe r <|> siSevenzExe l - , siSevenzDll = siSevenzDll r <|> siSevenzDll l - , siMsys2 = siMsys2 r <> siMsys2 l - , siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l) - , siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l) - , siStack = Map.unionWith (<>) (siStack l) (siStack r) } + mappend = (<>) -- | Remote or inline 'SetupInfo' data SetupInfoLocation @@ -1887,7 +1845,7 @@ {-# INLINE ghcVariantL #-} -- | Class for environment values that can provide a 'Config'. -class (HasPlatform env, HasRunner env) => HasConfig env where +class (HasPlatform env, HasProcessContext env, HasCabalLoader env) => HasConfig env where configL :: Lens' env Config default configL :: HasBuildConfig env => Lens' env Config configL = buildConfigL.lens bcConfig (\x y -> x { bcConfig = y }) @@ -1924,6 +1882,24 @@ ghcVariantL = lens bcGHCVariant (\x y -> x { bcGHCVariant = y }) instance HasGHCVariant EnvConfig +instance HasProcessContext Config where + processContextL = runnerL.processContextL +instance HasProcessContext LoadConfig where + processContextL = configL.processContextL +instance HasProcessContext BuildConfig where + processContextL = configL.processContextL +instance HasProcessContext EnvConfig where + processContextL = configL.processContextL + +instance HasCabalLoader Config where + cabalLoaderL = lens configCabalLoader (\x y -> x { configCabalLoader = y }) +instance HasCabalLoader LoadConfig where + cabalLoaderL = configL.cabalLoaderL +instance HasCabalLoader BuildConfig where + cabalLoaderL = configL.cabalLoaderL +instance HasCabalLoader EnvConfig where + cabalLoaderL = configL.cabalLoaderL + instance HasConfig Config where configL = id {-# INLINE configL #-} @@ -1964,16 +1940,16 @@ -- Helper lenses ----------------------------------- -stackRootL :: HasConfig s => Lens' s (Path Abs Dir) -stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) +stackRootL :: HasCabalLoader s => Lens' s (Path Abs Dir) +stackRootL = cabalLoaderL.lens clStackRoot (\x y -> x { clStackRoot = y }) --- | The compiler specified by the @MiniBuildPlan@. This may be +-- | The compiler specified by the @SnapshotDef@. This may be -- different from the actual compiler used! 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 +-- different than that specified in the 'SnapshotDef' and returned -- by 'wantedCompilerVersionL'. actualCompilerVersionL :: HasEnvConfig s => Lens' s (CompilerVersion 'CVActual) actualCompilerVersionL = envConfigL.lens @@ -1985,11 +1961,6 @@ bcSnapshotDef (\x y -> x { bcSnapshotDef = y }) -packageIndicesL :: HasConfig s => Lens' s [PackageIndex] -packageIndicesL = configL.lens - configPackageIndices - (\x y -> x { configPackageIndices = y }) - buildOptsL :: HasConfig s => Lens' s BuildOpts buildOptsL = configL.lens configBuild @@ -2046,17 +2017,20 @@ 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 }) +envOverrideSettingsL :: HasConfig env => Lens' env (EnvSettings -> IO ProcessContext) +envOverrideSettingsL = configL.lens + configProcessContextSettings + (\x y -> x { configProcessContextSettings = y }) +globalHintsL :: HasBuildConfig s => Getting r s (Map PackageName (Maybe Version)) +globalHintsL = snapshotDefL.to sdGlobalHints + shouldForceGhcColorFlag :: (HasRunner env, HasEnvConfig env) => RIO env Bool shouldForceGhcColorFlag = do canDoColor <- (>= $(mkVersion "8.2.1")) . getGhcVersion <$> view actualCompilerVersionL - shouldDoColor <- logUseColor <$> view logOptionsL + shouldDoColor <- view useColorL return $ canDoColor && shouldDoColor appropriateGhcColorFlag :: (HasRunner env, HasEnvConfig env) diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -64,6 +64,8 @@ -- ^ Watch files for changes and automatically rebuild ,boptsKeepGoing :: !(Maybe Bool) -- ^ Keep building/running after failure + ,boptsKeepTmpFiles :: !(Maybe Bool) + -- ^ Keep intermediate files and build directories ,boptsForceDirty :: !Bool -- ^ Force treating all local packages as having dirty files @@ -105,6 +107,7 @@ , boptsInstallCompilerTool = False , boptsPreFetch = False , boptsKeepGoing = Nothing + , boptsKeepTmpFiles = Nothing , boptsForceDirty = False , boptsTests = False , boptsTestOpts = defaultTestOpts @@ -172,6 +175,7 @@ , buildMonoidInstallCompilerTool :: !(First Bool) , buildMonoidPreFetch :: !(First Bool) , buildMonoidKeepGoing :: !(First Bool) + , buildMonoidKeepTmpFiles :: !(First Bool) , buildMonoidForceDirty :: !(First Bool) , buildMonoidTests :: !(First Bool) , buildMonoidTestOpts :: !TestOptsMonoid @@ -202,6 +206,7 @@ buildMonoidInstallCompilerTool <- First <$> o ..:? buildMonoidInstallCompilerToolArgName buildMonoidPreFetch <- First <$> o ..:? buildMonoidPreFetchArgName buildMonoidKeepGoing <- First <$> o ..:? buildMonoidKeepGoingArgName + buildMonoidKeepTmpFiles <- First <$> o ..:? buildMonoidKeepTmpFilesArgName buildMonoidForceDirty <- First <$> o ..:? buildMonoidForceDirtyArgName buildMonoidTests <- First <$> o ..:? buildMonoidTestsArgName buildMonoidTestOpts <- jsonSubWarnings (o ..:? buildMonoidTestOptsArgName ..!= mempty) @@ -255,6 +260,9 @@ buildMonoidKeepGoingArgName :: Text buildMonoidKeepGoingArgName = "keep-going" +buildMonoidKeepTmpFilesArgName :: Text +buildMonoidKeepTmpFilesArgName = "keep-tmp-files" + buildMonoidForceDirtyArgName :: Text buildMonoidForceDirtyArgName = "force-dirty" @@ -282,9 +290,12 @@ buildMonoidSkipComponentsName :: Text buildMonoidSkipComponentsName = "skip-components" +instance Semigroup BuildOptsMonoid where + (<>) = mappenddefault + instance Monoid BuildOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Which subset of packages to build data BuildSubset @@ -339,9 +350,12 @@ toMonoidDisableRunArgName :: Text toMonoidDisableRunArgName = "no-run-tests" +instance Semigroup TestOptsMonoid where + (<>) = mappenddefault + instance Monoid TestOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) @@ -362,9 +376,12 @@ (\o -> do hoMonoidAdditionalArgs <- o ..:? hoMonoidAdditionalArgsName ..!= [] return HaddockOptsMonoid{..}) +instance Semigroup HaddockOptsMonoid where + (<>) = mappenddefault + instance Monoid HaddockOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) hoMonoidAdditionalArgsName :: Text hoMonoidAdditionalArgsName = "haddock-args" @@ -401,9 +418,12 @@ beoMonoidDisableRunArgName :: Text beoMonoidDisableRunArgName = "no-run-benchmarks" +instance Semigroup BenchmarkOptsMonoid where + (<>) = mappenddefault + instance Monoid BenchmarkOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) data FileWatchOpts = NoFileWatch diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -9,7 +9,7 @@ module Stack.Types.Docker where -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Data.Aeson.Extended import Data.List (intercalate) import qualified Data.Text as T @@ -106,11 +106,11 @@ -- | Decode uninterpreted docker options from JSON/YAML. instance FromJSON (WithJSONWarnings DockerOptsMonoid) where parseJSON = withObjectWarnings "DockerOptsMonoid" - (\o -> do dockerMonoidDefaultEnable <- pure (Any True) + (\o -> do let dockerMonoidDefaultEnable = Any True dockerMonoidEnable <- First <$> o ..:? dockerEnableArgName dockerMonoidRepoOrImage <- First <$> - (((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|> - ((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|> + ((Just . DockerMonoidImage <$> o ..: dockerImageArgName) <|> + (Just . DockerMonoidRepo <$> o ..: dockerRepoArgName) <|> pure Nothing) dockerMonoidRegistryLogin <- First <$> o ..:? dockerRegistryLoginArgName dockerMonoidRegistryUsername <- First <$> o ..:? dockerRegistryUsernameArgName @@ -132,9 +132,13 @@ return DockerOptsMonoid{..}) -- | Left-biased combine Docker options +instance Semigroup DockerOptsMonoid where + (<>) = mappenddefault + +-- | Left-biased combine Docker options instance Monoid DockerOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Where to get the `stack` executable to run in Docker containers data DockerStackExe diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -51,9 +51,12 @@ { .. }) +instance Semigroup ImageOptsMonoid where + (<>) = mappenddefault + instance Monoid ImageOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) instance FromJSON (WithJSONWarnings ImageDockerOpts) where parseJSON = withObjectWarnings diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/NamedComponent.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Stack.Types.NamedComponent + ( NamedComponent (..) + , renderComponent + , renderPkgComponents + , renderPkgComponent + , exeComponents + , testComponents + , benchComponents + , isCLib + , isCExe + , isCTest + , isCBench + ) where + +import Stack.Prelude +import Stack.Types.PackageName +import qualified Data.Set as Set +import qualified Data.Text as T + +-- | A single, fully resolved component of a package +data NamedComponent + = CLib + | CInternalLib !Text + | CExe !Text + | CTest !Text + | CBench !Text + deriving (Show, Eq, Ord) + +renderComponent :: NamedComponent -> Text +renderComponent CLib = "lib" +renderComponent (CInternalLib x) = "internal-lib:" <> x +renderComponent (CExe x) = "exe:" <> x +renderComponent (CTest x) = "test:" <> x +renderComponent (CBench x) = "bench:" <> x + +renderPkgComponents :: [(PackageName, NamedComponent)] -> Text +renderPkgComponents = T.intercalate " " . map renderPkgComponent + +renderPkgComponent :: (PackageName, NamedComponent) -> Text +renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> renderComponent comp + +exeComponents :: Set NamedComponent -> Set Text +exeComponents = Set.fromList . mapMaybe mExeName . Set.toList + where + mExeName (CExe name) = Just name + mExeName _ = Nothing + +testComponents :: Set NamedComponent -> Set Text +testComponents = Set.fromList . mapMaybe mTestName . Set.toList + where + mTestName (CTest name) = Just name + mTestName _ = Nothing + +benchComponents :: Set NamedComponent -> Set Text +benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList + where + mBenchName (CBench name) = Just name + mBenchName _ = Nothing + +isCLib :: NamedComponent -> Bool +isCLib CLib{} = True +isCLib _ = False + +isCExe :: NamedComponent -> Bool +isCExe CExe{} = True +isCExe _ = False + +isCTest :: NamedComponent -> Bool +isCTest CTest{} = True +isCTest _ = False + +isCBench :: NamedComponent -> Bool +isCBench CBench{} = True +isCBench _ = False diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -31,9 +31,7 @@ -- | An uninterpreted representation of nix options. -- Configurations may be "cascaded" using mappend (left-biased). data NixOptsMonoid = NixOptsMonoid - {nixMonoidDefaultEnable :: !Any - -- ^ Should nix-shell be defaulted to enabled (does @nix:@ section exist in the config)? - ,nixMonoidEnable :: !(First Bool) + {nixMonoidEnable :: !(First Bool) -- ^ Is using nix-shell enabled? ,nixMonoidPureShell :: !(First Bool) -- ^ Should the nix-shell be pure @@ -53,8 +51,7 @@ -- | Decode uninterpreted nix options from JSON/YAML. instance FromJSON (WithJSONWarnings NixOptsMonoid) where parseJSON = withObjectWarnings "NixOptsMonoid" - (\o -> do nixMonoidDefaultEnable <- pure (Any False) - nixMonoidEnable <- First <$> o ..:? nixEnableArgName + (\o -> do nixMonoidEnable <- First <$> o ..:? nixEnableArgName nixMonoidPureShell <- First <$> o ..:? nixPureShellArgName nixMonoidPackages <- First <$> o ..:? nixPackagesArgName nixMonoidInitFile <- First <$> o ..:? nixInitFileArgName @@ -64,9 +61,13 @@ return NixOptsMonoid{..}) -- | Left-biased combine Nix options +instance Semigroup NixOptsMonoid where + (<>) = mappenddefault + +-- | Left-biased combine Nix options instance Monoid NixOptsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) -- | Nix enable argument name. nixEnableArgName :: Text diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -16,9 +16,8 @@ import qualified Data.Set as Set import Data.Store.Version (VersionConfig) import Data.Store.VersionTagged (storeVersionConfig) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import Distribution.InstalledPackageInfo (PError) +import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) +import qualified Distribution.SPDX.License as SPDX import Distribution.License (License) import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (TestSuiteInterface, BuildType) @@ -29,13 +28,18 @@ import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -- | All exceptions thrown by the library. data PackageException - = PackageInvalidCabalFile (Either PackageIdentifierRevision (Path Abs File)) PError + = PackageInvalidCabalFile + !(Either PackageIdentifierRevision (Path Abs File)) + !(Maybe Version) + ![PError] + ![PWarning] | PackageNoCabalFileFound (Path Abs Dir) | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File] | MismatchedCabalName (Path Abs File) PackageName @@ -43,19 +47,45 @@ deriving Typeable instance Exception PackageException instance Show PackageException where - show (PackageInvalidCabalFile loc err) = concat + show (PackageInvalidCabalFile loc _mversion errs warnings) = concat [ "Unable to parse cabal file " , case loc of Left pir -> "for " ++ packageIdentifierRevisionString pir Right fp -> toFilePath fp - , ": " - , show err + {- + + Not actually needed, the errors will indicate if a newer version exists. + Also, it seems that this is set to Just the version even if we support it. + + , case mversion of + Nothing -> "" + Just version -> "\nRequires newer Cabal file parser version: " ++ + versionString version + -} + , "\n\n" + , unlines $ map + (\(PError pos msg) -> concat + [ "- " + , showPos pos + , ": " + , msg + ]) + errs + , unlines $ map + (\(PWarning _ pos msg) -> concat + [ "- " + , showPos pos + , ": " + , msg + ]) + warnings ] show (PackageNoCabalFileFound dir) = concat [ "Stack looks for packages in the directories configured in" - , " the 'packages' variable defined in your stack.yaml\n" - , "The current entry points to " ++ toFilePath dir ++ - " but no .cabal file could be found there." + , " the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" + , "The current entry points to " + , toFilePath dir + , " but no .cabal or package.yaml file could be found there." ] show (PackageMultipleCabalFilesFound dir files) = "Multiple .cabal files found in directory " ++ @@ -90,7 +120,7 @@ data Package = Package {packageName :: !PackageName -- ^ Name of the package. ,packageVersion :: !Version -- ^ Version of the package - ,packageLicense :: !License -- ^ The license the package was released under. + ,packageLicense :: !(Either SPDX.License License) -- ^ The license the package was released under. ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package. ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on. ,packageTools :: !(Map ExeName VersionRange) -- ^ A build tool name. @@ -104,7 +134,7 @@ ,packageExes :: !(Set Text) -- ^ names of executables ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC. ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules? - ,packageBuildType :: !(Maybe BuildType) -- ^ Package build-type. + ,packageBuildType :: !BuildType -- ^ Package build-type. ,packageSetupDeps :: !(Maybe (Map PackageName VersionRange)) -- ^ If present: custom-setup dependencies } @@ -127,7 +157,7 @@ -> [PackageName] -> Path Abs File -> RIO env - (Map NamedComponent (Set ModuleName) + (Map NamedComponent (Map ModuleName (Path Abs File)) ,Map NamedComponent (Set DotCabalPath) ,Map NamedComponent BuildInfoOpts) } @@ -142,7 +172,7 @@ -- ^ These options can safely have 'nubOrd' applied to them, as -- there are no multi-word options (see -- https://github.com/commercialhaskell/stack/issues/1255) - , bioCabalMacros :: Maybe (Path Abs File) + , bioCabalMacros :: Path Abs File } deriving Show -- | Files to get for a cabal package. @@ -156,7 +186,7 @@ { getPackageFiles :: forall env. HasEnvConfig env => Path Abs File -> RIO env - (Map NamedComponent (Set ModuleName) + (Map NamedComponent (Map ModuleName (Path Abs File)) ,Map NamedComponent (Set DotCabalPath) ,Set (Path Abs File) ,[PackageWarning]) @@ -166,7 +196,7 @@ -- | Warning generated when reading a package data PackageWarning - = UnlistedModulesWarning (Maybe String) [ModuleName] + = UnlistedModulesWarning NamedComponent [ModuleName] -- ^ Modules found that are not listed in cabal file -- TODO: bring this back - see @@ -257,63 +287,19 @@ } deriving Show -renderComponent :: NamedComponent -> S.ByteString -renderComponent CLib = "lib" -renderComponent (CExe x) = "exe:" <> encodeUtf8 x -renderComponent (CTest x) = "test:" <> encodeUtf8 x -renderComponent (CBench x) = "bench:" <> encodeUtf8 x - -renderPkgComponents :: [(PackageName, NamedComponent)] -> Text -renderPkgComponents = T.intercalate " " . map renderPkgComponent - -renderPkgComponent :: (PackageName, NamedComponent) -> Text -renderPkgComponent (pkg, comp) = packageNameText pkg <> ":" <> decodeUtf8 (renderComponent comp) - -exeComponents :: Set NamedComponent -> Set Text -exeComponents = Set.fromList . mapMaybe mExeName . Set.toList - where - mExeName (CExe name) = Just name - mExeName _ = Nothing - -testComponents :: Set NamedComponent -> Set Text -testComponents = Set.fromList . mapMaybe mTestName . Set.toList - where - mTestName (CTest name) = Just name - mTestName _ = Nothing - -benchComponents :: Set NamedComponent -> Set Text -benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList - where - mBenchName (CBench name) = Just name - mBenchName _ = Nothing - -isCLib :: NamedComponent -> Bool -isCLib CLib{} = True -isCLib _ = False - -isCExe :: NamedComponent -> Bool -isCExe CExe{} = True -isCExe _ = False - -isCTest :: NamedComponent -> Bool -isCTest CTest{} = True -isCTest _ = False - -isCBench :: NamedComponent -> Bool -isCBench CBench{} = True -isCBench _ = False - lpFiles :: LocalPackage -> Set.Set (Path Abs File) lpFiles = Set.unions . M.elems . lpComponentFiles -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local deriving (Show, Eq) +instance Semigroup InstallLocation where + Local <> _ = Local + _ <> Local = Local + Snap <> Snap = Snap instance Monoid InstallLocation where mempty = Snap - mappend Local _ = Local - mappend _ Local = Local - mappend Snap Snap = Snap + mappend = (<>) data InstalledPackageLocation = InstalledTo InstallLocation | ExtraGlobal deriving (Show, Eq) @@ -397,7 +383,7 @@ type InstalledMap = Map PackageName (InstallLocation, Installed) data Installed - = Library PackageIdentifier GhcPkgId (Maybe License) + = Library PackageIdentifier GhcPkgId (Maybe (Either SPDX.License License)) | Executable PackageIdentifier deriving (Show, Eq) diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -80,6 +80,8 @@ instance Show PackageIdentifier where show = show . packageIdentifierString +instance Display PackageIdentifier where + display = fromString . packageIdentifierString instance ToJSON PackageIdentifier where toJSON = toJSON . packageIdentifierString diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -50,9 +50,12 @@ (index, Maybe PackageDownload, NonEmpty ([CabalHash], OffsetSize)))) deriving (Generic, Eq, Show, Data, Typeable, Store, NFData) +instance Semigroup (PackageCache index) where + PackageCache x <> PackageCache y = PackageCache (HashMap.unionWith HashMap.union x y) + instance Monoid (PackageCache index) where mempty = PackageCache HashMap.empty - mappend (PackageCache x) (PackageCache y) = PackageCache (HashMap.unionWith HashMap.union x y) + mappend = (<>) -- | offset in bytes into the 01-index.tar file for the .cabal file -- contents, and size in bytes of the .cabal file diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -60,6 +60,8 @@ instance Show PackageName where show (PackageName n) = T.unpack n +instance Display PackageName where + display (PackageName n) = display n instance FromJSON PackageName where parseJSON j = diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -68,7 +68,7 @@ -- | How we resolve which dependencies to install given a set of packages. data ResolverWith customContents - = ResolverSnapshot !SnapName -- FIXME rename to ResolverStackage + = ResolverStackage !SnapName -- ^ Use an official snapshot from the Stackage project, either an -- LTS Haskell or Stackage Nightly. @@ -92,7 +92,7 @@ instance ToJSON (ResolverWith a) where toJSON x = case x of - ResolverSnapshot name -> toJSON $ renderSnapName name + ResolverStackage name -> toJSON $ renderSnapName name ResolverCompiler version -> toJSON $ compilerVersionText version ResolverCustom loc _ -> toJSON loc instance a ~ () => FromJSON (ResolverWith a) where @@ -102,7 +102,7 @@ -- 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 (ResolverStackage name) = renderSnapName name resolverRawName (ResolverCompiler v) = compilerVersionText v resolverRawName (ResolverCustom loc _ ) = "custom: " <> loc @@ -124,13 +124,13 @@ $ T.stripPrefix "file://" t <|> T.stripPrefix "file:" t return $ toFilePath dir FP. rel Just req -> return $ Left req -parseCustomLocation _ (ResolverSnapshot name) = return $ ResolverSnapshot name +parseCustomLocation _ (ResolverStackage name) = return $ ResolverStackage name parseCustomLocation _ (ResolverCompiler cv) = return $ ResolverCompiler cv -- | Parse a @Resolver@ from a @Text@ parseResolverText :: Text -> ResolverWith () parseResolverText t - | Right x <- parseSnapName t = ResolverSnapshot x + | Right x <- parseSnapName t = ResolverStackage x | Just v <- parseCompilerVersion t = ResolverCompiler v | otherwise = ResolverCustom t () @@ -162,6 +162,8 @@ deriving (Generic, Typeable, Show, Data, Eq) instance Store SnapName instance NFData SnapName +instance Display SnapName where + display = display . renderSnapName data BuildPlanTypesException = ParseSnapNameException !Text diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -3,13 +3,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,43 +14,29 @@ ( Runner (..) , HasRunner (..) , terminalL + , useColorL , reExecL - , stickyL - , logOptionsL - , Sticky (..) - , LogOptions (..) , ColorWhen (..) , withRunner ) where -import qualified Data.ByteString.Char8 as S8 -import Data.Char -import Data.List (stripPrefix) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.Text.IO as T -import Data.Time import Distribution.PackageDescription (GenericPackageDescription) -import GHC.Foreign (peekCString, withCString) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (lift) import Lens.Micro import Stack.Prelude hiding (lift) import Stack.Constants import Stack.Types.PackageIdentifier (PackageIdentifierRevision) import System.Console.ANSI -import System.FilePath -import System.IO (localeEncoding) -import System.Log.FastLogger +import RIO.Process (HasProcessContext (..), ProcessContext, mkDefaultProcessContext) import System.Terminal -- | Monadic environment. data Runner = Runner { runnerReExec :: !Bool - , runnerLogOptions :: !LogOptions , runnerTerminal :: !Bool - , runnerSticky :: !Sticky + , runnerUseColor :: !Bool + , runnerLogFunc :: !LogFunc + , runnerTermWidth :: !Int + , runnerProcessContext :: !ProcessContext , runnerParsedCabalFiles :: !(IORef ( Map PackageIdentifierRevision GenericPackageDescription , Map (Path Abs Dir) (GenericPackageDescription, Path Abs File) @@ -70,192 +51,30 @@ -- . } -class HasLogFunc env => HasRunner env where +class (HasProcessContext env, HasLogFunc env) => HasRunner env where runnerL :: Lens' env Runner +instance HasProcessContext Runner where + processContextL = lens runnerProcessContext (\x y -> x { runnerProcessContext = y }) instance HasRunner Runner where runnerL = id terminalL :: HasRunner env => Lens' env Bool terminalL = runnerL.lens runnerTerminal (\x y -> x { runnerTerminal = y }) +useColorL :: HasRunner env => Lens' env Bool +useColorL = runnerL.lens runnerUseColor (\x y -> x { runnerUseColor = y }) + reExecL :: HasRunner env => Lens' env Bool reExecL = runnerL.lens runnerReExec (\x y -> x { runnerReExec = y }) -stickyL :: HasRunner env => Lens' env Sticky -stickyL = runnerL.lens runnerSticky (\x y -> x { runnerSticky = y }) - -logOptionsL :: HasRunner env => Lens' env LogOptions -logOptionsL = runnerL.lens runnerLogOptions (\x y -> x { runnerLogOptions = y }) - -newtype Sticky = Sticky - { unSticky :: Maybe (MVar (Maybe Text)) - } - -data LogOptions = LogOptions - { logUseColor :: Bool - , logTermWidth :: Int - , logUseUnicode :: Bool - , logUseTime :: Bool - , logMinLevel :: LogLevel - , logVerboseFormat :: Bool - } - -------------------------------------------------------------------------------- -- Logging functionality instance HasLogFunc Runner where - logFuncL = to $ \env -> stickyLoggerFuncImpl (view stickyL env) (view logOptionsL env) - -stickyLoggerFuncImpl - :: ToLogStr msg - => Sticky -> LogOptions - -> (Loc -> LogSource -> LogLevel -> msg -> IO ()) -stickyLoggerFuncImpl (Sticky mref) lo loc src level msg = - case mref of - Nothing -> - loggerFunc - lo - out - loc - src - (case level of - LevelOther "sticky-done" -> LevelInfo - LevelOther "sticky" -> LevelInfo - _ -> level) - msg - Just ref -> modifyMVar_ ref $ \sticky -> do - let backSpaceChar = '\8' - repeating = S8.replicate (maybe 0 T.length sticky) - clear = S8.hPutStr out - (repeating backSpaceChar <> - repeating ' ' <> - repeating backSpaceChar) - - -- Convert some GHC-generated Unicode characters as necessary - let msgText - | logUseUnicode lo = msgTextRaw - | otherwise = T.map replaceUnicode msgTextRaw - - case level of - LevelOther "sticky-done" -> do - clear - T.hPutStrLn out msgText - hFlush out - return Nothing - LevelOther "sticky" -> do - clear - T.hPutStr out msgText - hFlush out - return (Just msgText) - _ - | level >= logMinLevel lo -> do - clear - loggerFunc lo out loc src level $ toLogStr msgText - case sticky of - Nothing -> - return Nothing - Just line -> do - T.hPutStr out line >> hFlush out - return sticky - | otherwise -> - return sticky - where - out = stderr - msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes - msgBytes = fromLogStr (toLogStr msg) - --- | Replace Unicode characters with non-Unicode equivalents -replaceUnicode :: Char -> Char -replaceUnicode '\x2018' = '`' -replaceUnicode '\x2019' = '\'' -replaceUnicode c = c - --- | Logging function takes the log level into account. -loggerFunc :: ToLogStr msg - => LogOptions -> Handle -> Loc -> Text -> LogLevel -> msg -> IO () -loggerFunc lo outputChannel loc _src level msg = - when (level >= logMinLevel lo) - (liftIO (do out <- getOutput - T.hPutStrLn outputChannel out)) - where - getOutput = do - timestamp <- getTimestamp - l <- getLevel - lc <- getLoc - return $ T.concat - [ T.pack timestamp - , T.pack l - , T.pack (ansi [Reset]) - , T.decodeUtf8 (fromLogStr (toLogStr msg)) - , T.pack lc - , T.pack (ansi [Reset]) - ] - where - ansi xs | logUseColor lo = setSGRCode xs - | otherwise = "" - getTimestamp - | logVerboseFormat lo && logUseTime lo = - do now <- getZonedTime - return $ - ansi [SetColor Foreground Vivid Black] - ++ formatTime' now ++ ": " - | otherwise = return "" - where - formatTime' = - take timestampLength . formatTime defaultTimeLocale "%F %T.%q" - getLevel - | logVerboseFormat lo = - return ((case level of - LevelDebug -> ansi [SetColor Foreground Dull Green] - LevelInfo -> ansi [SetColor Foreground Dull Blue] - LevelWarn -> ansi [SetColor Foreground Dull Yellow] - LevelError -> ansi [SetColor Foreground Dull Red] - LevelOther _ -> ansi [SetColor Foreground Dull Magenta]) ++ - "[" ++ - map toLower (drop 5 (show level)) ++ - "] ") - | otherwise = return "" - getLoc - | logVerboseFormat lo = - return $ - ansi [SetColor Foreground Vivid Black] ++ - "\n@(" ++ fileLocStr ++ ")" - | otherwise = return "" - fileLocStr = - fromMaybe file (stripPrefix dirRoot file) ++ - ':' : - line loc ++ - ':' : - char loc - where - file = loc_filename loc - line = show . fst . loc_start - char = show . snd . loc_start - dirRoot = $(lift . T.unpack . fromMaybe undefined . T.stripSuffix (T.pack $ "Stack" "Types" "Runner.hs") . T.pack . loc_filename =<< location) - --- | The length of a timestamp in the format "YYYY-MM-DD hh:mm:ss.μμμμμμ". --- This definition is top-level in order to avoid multiple reevaluation at runtime. -timestampLength :: Int -timestampLength = - length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0)) - --- | With a sticky state, do the thing. -withSticky :: (MonadIO m) - => Bool -> (Sticky -> m b) -> m b -withSticky terminal m = - if terminal - then do state <- liftIO (newMVar Nothing) - originalMode <- liftIO (hGetBuffering stdout) - liftIO (hSetBuffering stdout NoBuffering) - a <- m (Sticky (Just state)) - state' <- liftIO (takeMVar state) - liftIO (when (isJust state') (S8.putStr "\n")) - liftIO (hSetBuffering stdout originalMode) - return a - else m (Sticky Nothing) + logFuncL = lens runnerLogFunc (\x y -> x { runnerLogFunc = y }) -- | With a 'Runner', do the thing -withRunner :: MonadIO m +withRunner :: MonadUnliftIO m => LogLevel -> Bool -- ^ use time? -> Bool -- ^ terminal? @@ -272,36 +91,29 @@ termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth <$> liftIO getTerminalWidth) pure widthOverride - canUseUnicode <- liftIO getCanUseUnicode ref <- newIORef mempty - withSticky terminal $ \sticky -> inner Runner + menv <- mkDefaultProcessContext + logOptions0 <- logOptionsHandle stderr False + let logOptions + = setLogUseColor useColor + $ setLogUseTime useTime + $ setLogMinLevel logLevel + $ setLogVerboseFormat (logLevel <= LevelDebug) + $ setLogTerminal terminal + logOptions0 + withLogFunc logOptions $ \logFunc -> inner Runner { runnerReExec = reExec - , runnerLogOptions = LogOptions - { logUseColor = useColor - , logTermWidth = termWidth - , logUseUnicode = canUseUnicode - , logUseTime = useTime - , logMinLevel = logLevel - , logVerboseFormat = logLevel <= LevelDebug - } , runnerTerminal = terminal - , runnerSticky = sticky + , runnerUseColor = useColor + , runnerLogFunc = logFunc + , runnerTermWidth = termWidth , runnerParsedCabalFiles = ref + , runnerProcessContext = menv } where clipWidth w | w < minTerminalWidth = minTerminalWidth | w > maxTerminalWidth = maxTerminalWidth | otherwise = w - --- | Taken from GHC: determine if we should use Unicode syntax -getCanUseUnicode :: IO Bool -getCanUseUnicode = do - let enc = localeEncoding - str = "\x2018\x2019" - test = withCString enc str $ \cstr -> do - str' <- peekCString enc cstr - return (str == str') - test `catchIO` \_ -> return False data ColorWhen = ColorNever | ColorAlways | ColorAuto deriving (Show, Generic) diff --git a/src/Stack/Types/Sig.hs b/src/Stack/Types/Sig.hs --- a/src/Stack/Types/Sig.hs +++ b/src/Stack/Types/Sig.hs @@ -6,7 +6,7 @@ {-| Module : Stack.Types.Sig Description : Signature Types -Copyright : (c) FPComplete.com, 2015 +Copyright : (c) 2015-2018, Stack contributors License : BSD3 Maintainer : Tim Dysinger Stability : experimental diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs --- a/src/Stack/Types/Urls.hs +++ b/src/Stack/Types/Urls.hs @@ -38,6 +38,9 @@ <*> o ..: "lts-build-plans" <*> o ..: "nightly-build-plans" +instance Semigroup UrlsMonoid where + (<>) = mappenddefault + instance Monoid UrlsMonoid where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -81,6 +81,8 @@ show (Version v) = intercalate "." (map show (V.toList v)) +instance Display Version where + display = display . versionText instance ToJSON Version where toJSON = toJSON . versionText @@ -99,10 +101,13 @@ IntersectingVersionRange { getIntersectingVersionRange :: Cabal.VersionRange } deriving Show +instance Semigroup IntersectingVersionRange where + IntersectingVersionRange l <> IntersectingVersionRange r = + IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) + instance Monoid IntersectingVersionRange where mempty = IntersectingVersionRange Cabal.anyVersion - mappend (IntersectingVersionRange l) (IntersectingVersionRange r) = - IntersectingVersionRange (l `Cabal.intersectVersionRanges` r) + mappend = (<>) -- | Attoparsec parser for a package version. versionParser :: Parser Version diff --git a/src/Stack/Types/VersionIntervals.hs b/src/Stack/Types/VersionIntervals.hs --- a/src/Stack/Types/VersionIntervals.hs +++ b/src/Stack/Types/VersionIntervals.hs @@ -53,9 +53,8 @@ (toCabal y) toCabal :: VersionIntervals -> C.VersionIntervals -toCabal (VersionIntervals vi) = fromMaybe - (error "Stack.Types.VersionIntervals.toCabal: invariant violated") - (C.mkVersionIntervals $ map go vi) +toCabal (VersionIntervals vi) = + C.mkVersionIntervals $ map go vi where go (VersionInterval lowerV lowerB mupper) = ( C.LowerBound (toCabalVersion lowerV) (toCabalBound lowerB) diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -12,7 +12,7 @@ , upgradeOpts ) where -import Stack.Prelude hiding (force) +import Stack.Prelude hiding (force, Display (..)) import qualified Data.HashMap.Strict as HashMap import qualified Data.List import qualified Data.Map as Map @@ -36,7 +36,7 @@ import Stack.Types.Resolver import System.Exit (ExitCode (ExitSuccess)) import System.Process (rawSystem, readProcess) -import System.Process.Run +import RIO.Process upgradeOpts :: Parser UpgradeOpts upgradeOpts = UpgradeOpts @@ -187,10 +187,9 @@ -> RIO env () sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = withSystemTempDir "stack-upgrade" $ \tmp -> do - menv <- getMinimalEnvOverride mdir <- case gitRepo of Just (repo, branch) -> do - remote <- liftIO $ readProcess "git" ["ls-remote", repo, branch] [] + remote <- liftIO $ System.Process.readProcess "git" ["ls-remote", repo, branch] [] latestCommit <- case words remote of [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo @@ -212,7 +211,7 @@ -- the stack repo until we're comfortable with "stack upgrade -- --git" not working for earlier versions. let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch] - runCmd (Cmd (Just tmp) "git" menv args) Nothing + withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_ return $ Just $ tmp $(mkRelDir "stack") Nothing -> do updateAllIndices diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -29,12 +29,11 @@ import Network.HTTP.Client (Response, RequestBody(RequestBodyLBS), Request) -import Network.HTTP.Simple (withResponse, - getResponseStatusCode, +import Network.HTTP.StackClient (withResponse, httpNoBody) +import Network.HTTP.Simple (getResponseStatusCode, getResponseBody, setRequestHeader, - parseRequest, - httpNoBody) + parseRequest) import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody, partBS, partLBS) import Network.HTTP.Client.TLS (getGlobalManager, @@ -125,7 +124,7 @@ credsFile :: Config -> IO FilePath credsFile config = do - let dir = toFilePath (configStackRoot config) "upload" + let dir = toFilePath (view stackRootL config) "upload" createDirectoryIfMissing True dir return $ dir "credentials.json" diff --git a/src/System/Process/Log.hs b/src/System/Process/Log.hs deleted file mode 100644 --- a/src/System/Process/Log.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Separate module because TH. - -module System.Process.Log - (logCreateProcess - ,withProcessTimeLog - ,showProcessArgDebug) - where - -import qualified Data.Text as T -import Stack.Prelude -import qualified System.Clock as Clock -import System.Process (CreateProcess(..), CmdSpec(..)) - --- | Log running a process with its arguments, for debugging (-v). -logCreateProcess :: MonadLogger m => CreateProcess -> m () -logCreateProcess CreateProcess { cmdspec = ShellCommand shellCmd } = - logDebug ("Creating shell process: " <> T.pack shellCmd) -logCreateProcess CreateProcess { cmdspec = RawCommand name args } = - logDebug - ("Creating process: " <> T.pack name <> " " <> - T.intercalate - " " - (map showProcessArgDebug args)) - --- | Log running a process with its arguments, for debugging (-v). --- --- This logs one message before running the process and one message after. -withProcessTimeLog :: (MonadIO m, MonadLogger m) => String -> [String] -> m a -> m a -withProcessTimeLog name args proc = do - let cmdText = - T.intercalate - " " - (T.pack name : map showProcessArgDebug args) - logDebug ("Run process: " <> cmdText) - start <- liftIO $ Clock.getTime Clock.Monotonic - x <- proc - end <- liftIO $ Clock.getTime Clock.Monotonic - let diff = Clock.diffTimeSpec start end - -- useAnsi <- asks getAnsiTerminal - let useAnsi = True - logDebug - ("Process finished in " <> - (if useAnsi then "\ESC[92m" else "") <> -- green - timeSpecMilliSecondText diff <> - (if useAnsi then "\ESC[0m" else "") <> -- reset - ": " <> cmdText) - return x - -timeSpecMilliSecondText :: Clock.TimeSpec -> Text -timeSpecMilliSecondText t = - (T.pack . show . (`div` 10^(6 :: Int)) . Clock.toNanoSecs) t <> "ms" - --- | Show a process arg including speechmarks when necessary. Just for --- debugging purposes, not functionally important. -showProcessArgDebug :: String -> Text -showProcessArgDebug x - | any special x || null x = T.pack (show x) - | otherwise = T.pack x - where special '"' = True - special ' ' = True - special _ = False diff --git a/src/System/Process/PagerEditor.hs b/src/System/Process/PagerEditor.hs --- a/src/System/Process/PagerEditor.hs +++ b/src/System/Process/PagerEditor.hs @@ -7,6 +7,7 @@ (-- * Pager pageWriter ,pageByteString + ,pageText ,pageBuilder ,pageFile ,pageString @@ -19,9 +20,9 @@ ,EditorException(..)) where -import Stack.Prelude hiding (ByteString) -import Data.ByteString.Lazy (ByteString,hPut,readFile) -import Data.ByteString.Builder (Builder,stringUtf8,hPutBuilder) +import qualified Data.ByteString.Lazy (readFile) +import Data.ByteString.Lazy (hPut) +import Stack.Prelude import System.Directory (findExecutable) import System.Environment (lookupEnv) import System.Exit (ExitCode(..)) @@ -29,6 +30,7 @@ import System.Process (createProcess,shell,proc,waitForProcess,StdStream (CreatePipe) ,CreateProcess(std_in, close_fds, delegate_ctlc)) import System.IO (hPutStr,readFile,stdout) +import qualified Data.Text.IO as T -- | Run pager, providing a function that writes to the pager's input. pageWriter :: (Handle -> IO ()) -> IO () @@ -52,9 +54,13 @@ Nothing -> writer stdout -- | Run pager to display a lazy ByteString. -pageByteString :: ByteString -> IO () +pageByteString :: LByteString -> IO () pageByteString = pageWriter . flip hPut +-- | Run pager to display a 'Text' +pageText :: Text -> IO () +pageText = pageWriter . flip T.hPutStr + -- | Run pager to display a ByteString-Builder. pageBuilder :: Builder -> IO () pageBuilder = pageWriter . flip hPutBuilder @@ -65,7 +71,7 @@ -- | Run pager to display a string. pageString :: String -> IO () -pageString = pageBuilder . stringUtf8 +pageString = pageBuilder . fromString -- | Run editor to edit a file. editFile :: FilePath -> IO () @@ -95,7 +101,7 @@ reader p') -- | Run editor on a ByteString. -editByteString :: String -> ByteString -> IO ByteString +editByteString :: String -> LByteString -> IO LByteString editByteString f s = editReaderWriter f (`hPut` s) Data.ByteString.Lazy.readFile -- | Run editor on a String. diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs deleted file mode 100644 --- a/src/System/Process/Read.hs +++ /dev/null @@ -1,436 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Reading from external processes. - -module System.Process.Read - (readProcessStdout - ,readProcessStderrStdout - ,tryProcessStdout - ,tryProcessStderrStdout - ,sinkProcessStdout - ,sinkProcessStderrStdout - ,sinkProcessStderrStdoutHandle - ,logProcessStderrStdout - ,readProcess - ,EnvOverride(..) - ,unEnvOverride - ,mkEnvOverride - ,modifyEnvOverride - ,envHelper - ,doesExecutableExist - ,findExecutable - ,getEnvOverride - ,envSearchPath - ,preProcess - ,readProcessNull - ,ReadProcessException (..) - ,augmentPath - ,augmentPathMap - ,resetExeCache - ) - where - -import Stack.Prelude -import qualified Data.ByteString as S -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as L -import Data.Conduit -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.Process hiding (callProcess) -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import Distribution.System (OS (Windows), Platform (Platform)) -import Path -import Path.Extra -import Path.IO hiding (findExecutable) -import qualified System.Directory as D -import System.Environment (getEnvironment) -import System.Exit -import qualified System.FilePath as FP -import System.Process.Log - --- | Override the environment received by a child process. -data EnvOverride = EnvOverride - { eoTextMap :: Map Text Text -- ^ Environment variables as map - , eoStringList :: [(String, String)] -- ^ Environment variables as association list - , eoPath :: [FilePath] -- ^ List of directories searched for executables (@PATH@) - , eoExeCache :: IORef (Map FilePath (Either ReadProcessException (Path Abs File))) - , eoExeExtensions :: [String] -- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows - , eoPlatform :: Platform - } - --- | Get the environment variables from an 'EnvOverride'. -unEnvOverride :: EnvOverride -> Map Text Text -unEnvOverride = eoTextMap - --- | Get the list of directories searched (@PATH@). -envSearchPath :: EnvOverride -> [FilePath] -envSearchPath = eoPath - --- | Modify the environment variables of an 'EnvOverride'. -modifyEnvOverride :: MonadIO m - => EnvOverride - -> (Map Text Text -> Map Text Text) - -> m EnvOverride -modifyEnvOverride eo f = mkEnvOverride - (eoPlatform eo) - (f $ eoTextMap eo) - --- | Create a new 'EnvOverride'. -mkEnvOverride :: MonadIO m - => Platform - -> Map Text Text - -> m EnvOverride -mkEnvOverride platform tm' = do - ref <- liftIO $ newIORef Map.empty - return EnvOverride - { eoTextMap = tm - , eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm - , eoPath = - (if isWindows then (".":) else id) - (maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm)) - , eoExeCache = ref - , eoExeExtensions = - if isWindows - then let pathext = fromMaybe - ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC" - (Map.lookup "PATHEXT" tm) - in map T.unpack $ "" : T.splitOn ";" pathext - else [""] - , eoPlatform = platform - } - where - -- Fix case insensitivity of the PATH environment variable on Windows. - tm - | isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm' - | otherwise = tm' - - -- Don't use CPP so that the Windows code path is at least type checked - -- regularly - isWindows = - case platform of - Platform _ Windows -> True - _ -> False - --- | Helper conversion function. -envHelper :: EnvOverride -> Maybe [(String, String)] -envHelper = Just . eoStringList - --- | Read from the process, ignoring any output. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessNull :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional working directory - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m () -readProcessNull wd menv name args = - sinkProcessStdout wd menv name args CL.sinkNull - --- | Try to produce a strict 'S.ByteString' from the stdout of a --- process. -tryProcessStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (Either ReadProcessException S.ByteString) -tryProcessStdout wd menv name args = - try (readProcessStdout wd menv name args) - --- | Try to produce strict 'S.ByteString's from the stderr and stdout of a --- process. -tryProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (Either ReadProcessException (S.ByteString, S.ByteString)) -tryProcessStderrStdout wd menv name args = - try (readProcessStderrStdout wd menv name args) - --- | Produce a strict 'S.ByteString' from the stdout of a process. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m S.ByteString -readProcessStdout wd menv name args = - sinkProcessStdout wd menv name args CL.consume >>= - liftIO . evaluate . S.concat - --- | Produce strict 'S.ByteString's from the stderr and stdout of a process. --- --- Throws a 'ReadProcessException' exception if the process fails. -readProcessStderrStdout :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> m (S.ByteString, S.ByteString) -readProcessStderrStdout wd menv name args = do - (e, o) <- sinkProcessStderrStdout wd menv name args CL.consume CL.consume - liftIO $ (,) <$> evaluate (S.concat e) <*> evaluate (S.concat o) - --- | An exception while trying to read from process. -data ReadProcessException - = ProcessFailed CreateProcess ExitCode L.ByteString L.ByteString - -- ^ @'ProcessFailed' createProcess exitCode stdout stderr@ - | NoPathFound - | ExecutableNotFound String [FilePath] - | ExecutableNotFoundAt FilePath - deriving Typeable -instance Show ReadProcessException where - show (ProcessFailed cp ec out err) = concat $ - [ "Running " - , showSpec $ cmdspec cp] ++ - maybe [] (\x -> [" in directory ", x]) (cwd cp) ++ - [ " exited with " - , show ec - , "\n\n" - , toStr out - , "\n" - , toStr err - ] - where - toStr = LT.unpack . LT.decodeUtf8With lenientDecode - - showSpec (ShellCommand str) = str - showSpec (RawCommand cmd args) = - unwords $ cmd : map (T.unpack . showProcessArgDebug) args - show NoPathFound = "PATH not found in EnvOverride" - show (ExecutableNotFound name path) = concat - [ "Executable named " - , name - , " not found on path: " - , show path - ] - show (ExecutableNotFoundAt name) = - "Did not find executable at specified path: " ++ name -instance Exception ReadProcessException - --- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer. --- If the process fails, spits out stdout and stderr as error log --- level. Should not be used for long-running processes or ones with --- lots of output; for that use 'sinkProcessStdoutLogStderr'. --- --- Throws a 'ReadProcessException' if unsuccessful. -sinkProcessStdout - :: (MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> Sink S.ByteString IO a -- ^ Sink for stdout - -> m a -sinkProcessStdout wd menv name args sinkStdout = do - stderrBuffer <- liftIO (newIORef mempty) - stdoutBuffer <- liftIO (newIORef mempty) - (_,sinkRet) <- - catch - (sinkProcessStderrStdout - wd - menv - name - args - (CL.mapM_ (\bytes -> liftIO (modifyIORef' stderrBuffer (<> byteString bytes)))) - (CL.iterM (\bytes -> liftIO (modifyIORef' stdoutBuffer (<> byteString bytes))) $= - sinkStdout)) - (\(ProcessExitedUnsuccessfully cp ec) -> - do stderrBuilder <- liftIO (readIORef stderrBuffer) - stdoutBuilder <- liftIO (readIORef stdoutBuffer) - liftIO $ throwM $ ProcessFailed - cp - ec - (toLazyByteString stdoutBuilder) - (toLazyByteString stderrBuilder)) - return sinkRet - -logProcessStderrStdout - :: (HasCallStack, MonadUnliftIO m, MonadLogger m) - => Maybe (Path Abs Dir) - -> String - -> EnvOverride - -> [String] - -> m () -logProcessStderrStdout mdir name menv args = withUnliftIO $ \u -> do - let logLines = CB.lines =$ CL.mapM_ (unliftIO u . logInfo . decodeUtf8With lenientDecode) - ((), ()) <- 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. --- --- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. -sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> Sink S.ByteString IO e -- ^ Sink for stderr - -> Sink S.ByteString IO o -- ^ Sink for stdout - -> m (e,o) -sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do - name' <- preProcess wd menv name - withProcessTimeLog name' args $ - liftIO $ withCheckedProcess - (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd } - (\ClosedStream out err -> f err out) - where - - -- There is a bug in streaming-commons or conduit-extra which - -- leads to a file descriptor leak. Ideally, we should be able to - -- simply use the following code. Instead, we're using the code - -- below it, which is explicit in closing Handles. When the - -- upstream bug is fixed, we can consider moving back to the - -- simpler code, though there's really no downside to the more - -- complex version used here. - -- - -- f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o) - -- f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout) - - f :: Handle -> Handle -> IO (e, o) - f err out = ((CB.sourceHandle err $$ sinkStderr) `concurrently` (CB.sourceHandle out $$ sinkStdout)) - `finally` hClose err `finally` hClose out - --- | Like sinkProcessStderrStdout, but receives Handles for stderr and stdout instead of 'Sink's. --- --- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ProcessExitedUnsuccessfully' if the process itself fails. -sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m) - => Maybe (Path Abs Dir) -- ^ Optional directory to run in - -> EnvOverride - -> String -- ^ Command - -> [String] -- ^ Command line arguments - -> Handle - -> Handle - -> m () -sinkProcessStderrStdoutHandle wd menv name args err out = do - name' <- preProcess wd menv name - withProcessTimeLog name' args $ - liftIO $ withCheckedProcess - (proc name' args) - { env = envHelper menv - , cwd = fmap toFilePath wd - , std_err = UseHandle err - , std_out = UseHandle out - } - (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ()) - --- | Perform pre-call-process tasks. Ensure the working directory exists and find the --- executable path. --- --- Throws a 'ReadProcessException' if unsuccessful. -preProcess :: (MonadIO m) - => Maybe (Path Abs Dir) -- ^ Optional directory to create if necessary - -> EnvOverride -- ^ How to override environment - -> String -- ^ Command name - -> m FilePath -preProcess wd menv name = do - name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name - maybe (return ()) ensureDir wd - return name' - --- | Check if the given executable exists on the given PATH. -doesExecutableExist :: (MonadIO m) - => EnvOverride -- ^ How to override environment - -> String -- ^ Name of executable - -> m Bool -doesExecutableExist menv name = liftM isJust $ findExecutable menv name - --- | Find the complete path for the executable. --- --- Throws a 'ReadProcessException' if unsuccessful. -findExecutable :: (MonadIO m, MonadThrow n) - => EnvOverride -- ^ How to override environment - -> String -- ^ Name of executable - -> m (n (Path Abs File)) -- ^ Full path to that executable on success -findExecutable eo name0 | any FP.isPathSeparator name0 = do - let names0 = map (name0 ++) (eoExeExtensions eo) - testNames [] = return $ throwM $ ExecutableNotFoundAt name0 - testNames (name:names) = do - exists <- liftIO $ D.doesFileExist name - if exists - then do - path <- liftIO $ resolveFile' name - return $ return path - else testNames names - testNames names0 -findExecutable eo name = liftIO $ do - m <- readIORef $ eoExeCache eo - epath <- case Map.lookup name m of - Just epath -> return epath - Nothing -> do - let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo) - loop (dir:dirs) = do - let fp0 = dir FP. name - fps0 = map (fp0 ++) (eoExeExtensions eo) - testFPs [] = loop dirs - testFPs (fp:fps) = do - exists <- D.doesFileExist fp - existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False - if existsExec - then do - fp' <- D.makeAbsolute fp >>= parseAbsFile - return $ return fp' - else testFPs fps - testFPs fps0 - epath <- loop $ eoPath eo - () <- atomicModifyIORef (eoExeCache eo) $ \m' -> - (Map.insert name epath m', ()) - return epath - return $ either throwM return epath - --- | Reset the executable cache. -resetExeCache :: MonadIO m => EnvOverride -> m () -resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty)) - --- | Load up an 'EnvOverride' from the standard environment. -getEnvOverride :: MonadIO m => Platform -> m EnvOverride -getEnvOverride platform = - liftIO $ - getEnvironment >>= - mkEnvOverride platform - . Map.fromList . map (T.pack *** T.pack) - -newtype InvalidPathException = PathsInvalidInPath [FilePath] - deriving Typeable - -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 " - ++ show FP.searchPathSeparator ++ "." - , "Please fix the following paths and try again:" - ] ++ paths - --- | Augment the PATH environment variable with the given extra paths. -augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text -augmentPath dirs mpath = - do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs) - unless (null illegal) (throwM $ PathsInvalidInPath illegal) - return $ T.intercalate (T.singleton FP.searchPathSeparator) - $ map (T.pack . toFilePathNoTrailingSep) dirs - ++ maybeToList mpath - --- | Apply 'augmentPath' on the PATH value in the given Map. -augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text - -> m (Map Text Text) -augmentPathMap dirs origEnv = - do path <- augmentPath dirs mpath - return $ Map.insert "PATH" path origEnv - where - mpath = Map.lookup "PATH" origEnv diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs deleted file mode 100644 --- a/src/System/Process/Run.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} --- | Run sub-processes. - -module System.Process.Run - (runCmd - ,runCmd' - ,callProcess - ,callProcess' - ,callProcessInheritStderrStdout - ,callProcessObserveStdout - ,createProcess' - ,ProcessExitedUnsuccessfully - ,Cmd(..) - ) - where - -import Stack.Prelude -import Data.Conduit.Process hiding (callProcess) -import qualified Data.Text as T -import System.Exit (exitWith, ExitCode (..)) -import System.IO (hGetLine) -import qualified System.Process -import System.Process.Log -import System.Process.Read - --- | Cmd holds common infos needed to running a process in most cases -data Cmd = Cmd - { cmdDirectoryToRunIn :: Maybe (Path Abs Dir) -- ^ directory to run in - , cmdCommandToRun :: FilePath -- ^ command to run - , cmdEnvOverride :: EnvOverride - , cmdCommandLineArguments :: [String] -- ^ command line arguments - } - --- | Run the given command in the given directory, inheriting stdout and stderr. --- --- If it exits with anything but success, prints an error --- and then calls 'exitWith' to exit the program. -runCmd :: forall (m :: * -> *). - (MonadLogger m, MonadUnliftIO m) - => Cmd - -> Maybe Text -- ^ optional additional error message - -> m () -runCmd = runCmd' id - -runCmd' :: forall (m :: * -> *). - (MonadLogger m, MonadUnliftIO m) - => (CreateProcess -> CreateProcess) - -> Cmd - -> Maybe Text -- ^ optional additional error message - -> m () -runCmd' modCP cmd@Cmd{..} mbErrMsg = do - result <- try (callProcess' modCP cmd) - case result of - Left (ProcessExitedUnsuccessfully _ ec) -> do - logError $ - T.pack $ - concat $ - [ "Exit code " - , show ec - , " while running " - , show (cmdCommandToRun : cmdCommandLineArguments) - ] ++ (case cmdDirectoryToRunIn of - Nothing -> [] - Just mbDir -> [" in ", toFilePath mbDir] - ) - forM_ mbErrMsg logError - liftIO (exitWith ec) - Right () -> return () - --- | Like 'System.Process.callProcess', but takes an optional working directory and --- environment override, and throws 'ProcessExitedUnsuccessfully' if the --- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. --- --- Inherits stdout and stderr. -callProcess :: (MonadIO m, MonadLogger m) => Cmd -> m () -callProcess = callProcess' id - --- | Like 'System.Process.callProcess', but takes an optional working directory and --- environment override, and throws 'ProcessExitedUnsuccessfully' if the --- process exits unsuccessfully and a 'ReadProcessException' if the executable is not found. --- --- Inherits stdout and stderr. -callProcess' :: (MonadIO m, MonadLogger m) - => (CreateProcess -> CreateProcess) -> Cmd -> m () -callProcess' modCP cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ do - (_, _, _, p) <- System.Process.createProcess c - exit_code <- waitForProcess p - case exit_code of - ExitSuccess -> return () - ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) - -callProcessInheritStderrStdout :: (MonadIO m, MonadLogger m) => Cmd -> m () -callProcessInheritStderrStdout cmd = do - let inheritOutput cp = cp { std_in = CreatePipe, std_out = Inherit, std_err = Inherit } - callProcess' inheritOutput cmd - -callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String -callProcessObserveStdout cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ do - (_, Just hStdout, _, p) <- System.Process.createProcess c - hSetBuffering hStdout NoBuffering - exit_code <- waitForProcess p - case exit_code of - ExitSuccess -> hGetLine hStdout - ExitFailure _ -> throwM (ProcessExitedUnsuccessfully c exit_code) - where - modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } - --- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'. --- Note that the 'Handle's provided by 'UseHandle' are not closed --- automatically. -createProcess' :: (MonadIO m, MonadLogger m) - => String - -> (CreateProcess -> CreateProcess) - -> Cmd - -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess' tag modCP cmd = do - c <- liftM modCP (cmdToCreateProcess cmd) - logCreateProcess c - liftIO $ System.Process.createProcess_ tag c - --- Throws a 'ReadProcessException' if process is not found. -cmdToCreateProcess :: MonadIO m => Cmd -> m CreateProcess -cmdToCreateProcess (Cmd wd cmd0 menv args) = do - cmd <- preProcess wd menv cmd0 - return $ (proc cmd args) { delegate_ctlc = True - , cwd = fmap toFilePath wd - , env = envHelper menv } diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -124,7 +124,7 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LTB -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), ConsoleIntensity(..), SGR(..), setSGRCode, hSupportsANSI) import qualified Text.PrettyPrint.Annotated.Leijen as P import Text.PrettyPrint.Annotated.Leijen hiding ((<>), display) @@ -137,8 +137,10 @@ -- Perhaps it can still have native string support, by adding a type -- parameter to Doc? +instance Semigroup (Doc a) where + (<>) = (P.<>) instance Monoid (Doc a) where - mappend = (P.<>) + mappend = (<>) mempty = empty -------------------------------------------------------------------------------- @@ -162,7 +164,7 @@ type AnsiDoc = Doc AnsiAnn newtype AnsiAnn = AnsiAnn [SGR] - deriving (Eq, Show, Monoid) + deriving (Eq, Show, Semigroup, Monoid) class HasAnsiAnn a where getAnsiAnn :: a -> AnsiAnn diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -18,7 +18,7 @@ #ifndef HIDE_DEP_VERSIONS import qualified Build_stack #endif -import Stack.Prelude +import Stack.Prelude hiding (Display (..)) import Control.Monad.Reader (local) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Writer.Lazy (Writer) @@ -30,15 +30,14 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Version (showVersion) -import System.Process.Read +import RIO.Process #ifdef USE_GIT_INFO import Development.GitRev (gitCommitCount, gitHash) #endif -import Distribution.System (buildArch, buildPlatform) +import Distribution.System (buildArch) import qualified Distribution.Text as Cabal (display) import Distribution.Version (mkVersion') import GHC.IO.Encoding (mkTextEncoding, textEncodingName) -import Lens.Micro import Options.Applicative import Options.Applicative.Help (errorHelp, stringChunk, vcatChunks) import Options.Applicative.Builder.Extra @@ -59,13 +58,13 @@ import Stack.Coverage import qualified Stack.Docker as Docker import Stack.Dot -import Stack.Exec import Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix import Stack.Fetch import Stack.FileWatch import Stack.Ghci import Stack.Hoogle +import Stack.Ls import qualified Stack.IDE as IDE import qualified Stack.Image as Image import Stack.Init @@ -105,7 +104,7 @@ import System.Environment (getProgName, getArgs, withArgs) import System.Exit import System.FilePath (isValid, pathSeparator) -import System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hGetEncoding, hSetEncoding) +import System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hPrint, hGetEncoding, hSetEncoding) -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception @@ -150,10 +149,10 @@ #else warningString = unlines [ "" - , "Warning: this is an unsupported build that may have been built with different" - , "versions of dependencies and GHC than the officially release binaries, and" - , "therefore may not behave identically. If you encounter problems, please try" - , "the latest official build by running 'stack upgrade --force-download'." + , "Warning: this is an unsupported build that may use different versions of" + , "dependencies and GHC than the officially released binaries, and therefore may" + , "not behave identically. If you encounter problems, please try the latest" + , "official build by running 'stack upgrade --force-download'." ] #endif @@ -198,7 +197,7 @@ case fromException e of Just ec -> exitWith ec Nothing -> do - printExceptionStderr e + hPrint stderr e exitFailure -- Vertically combine only the error component of the first argument with the @@ -299,10 +298,16 @@ "Print out handy path information" pathCmd Stack.Path.pathParser + addCommand' "ls" + "List command. (Supports snapshots and dependencies)" + lsCmd + lsParser addCommand' "unpack" "Unpack one or more packages locally" unpackCmd - (some $ strArgument $ metavar "PACKAGE") + ((,) <$> some (strArgument $ metavar "PACKAGE") + <*> optional (textOption $ long "to" <> + help "Optional path to unpack the package into (will unpack into subdirectory)")) addCommand' "update" "Update the package index" updateCmd @@ -333,7 +338,7 @@ ("Run hoogle, the Haskell API search engine. Use 'stack exec' syntax " ++ "to pass Hoogle arguments, e.g. stack hoogle -- --count=20") hoogleCmd - ((,,) <$> many (strArgument (metavar "ARG")) + ((,,,) <$> many (strArgument (metavar "ARG")) <*> boolFlags True "setup" @@ -341,7 +346,10 @@ idm <*> switch (long "rebuild" <> - help "Rebuild the hoogle database")) + help "Rebuild the hoogle database") + <*> switch + (long "server" <> + help "Start local Hoogle server")) ) -- These are the only commands allowed in interpreter mode as well @@ -381,7 +389,7 @@ cleanOptsParser addCommand' "list-dependencies" "List the dependencies" - listDependenciesCmd + (listDependenciesCmd True) listDepsOptsParser addCommand' "query" "Query general build information (experimental)" @@ -502,12 +510,11 @@ else do mExternalExec <- D.findExecutable cmd case mExternalExec of - Just ex -> do - menv <- getEnvOverride buildPlatform + Just ex -> withProcessContextNoLogging $ do -- TODO show the command in verbose mode -- hPutStrLn stderr $ unwords $ -- ["Running", "[" ++ ex, unwords (tail args) ++ "]"] - _ <- runNoLogging (exec menv ex (tail args)) + _ <- exec ex (tail args) return f Nothing -> return $ fmap (vcatErrorHelp (noSuchCmd cmd)) f where @@ -563,8 +570,12 @@ progName <- getProgName iargs <- getInterpreterArgs path let parseCmdLine = commandLineHandler currentDir progName True - separator = if "--" `elem` iargs then [] else ["--"] - cmdArgs = stackArgs ++ iargs ++ separator ++ path : fileArgs + -- Implicit file arguments are put before other arguments that + -- occur after "--". See #3658 + cmdArgs = stackArgs ++ case break (== "--") iargs of + (beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs + (beforeSep, optSep : afterSep) -> + beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep -- TODO show the command in verbose mode -- hPutStrLn stderr $ unwords $ -- ["Running", "[" ++ progName, unwords cmdArgs ++ "]"] @@ -578,7 +589,7 @@ setupCmd sco@SetupCmdOpts{..} go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> do when (isJust scoUpgradeCabal && nixEnable (configNix (lcConfig lc))) $ do throwIO UpgradeCabalUnusable - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do + withUserFileLock go (view stackRootL lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer @@ -605,8 +616,8 @@ -- See issues #2010 and #3468 for why "stack clean --full" is not used -- within docker. case opts of - CleanFull{} -> withBuildConfigAndLock go (const (clean opts)) - CleanShallow{} -> withBuildConfigAndLockNoDocker go (const (clean opts)) + CleanFull{} -> withBuildConfigAndLockNoDocker go (const (clean opts)) + CleanShallow{} -> withBuildConfigAndLock go (const (clean opts)) -- | Helper for build and install commands buildCmd :: BuildOptsCLI -> GlobalOpts -> IO () @@ -641,10 +652,11 @@ ] -- | Unpack packages to the filesystem -unpackCmd :: [String] -> GlobalOpts -> IO () -unpackCmd names go = withConfigAndLock go $ do +unpackCmd :: ([String], Maybe Text) -> GlobalOpts -> IO () +unpackCmd (names, Nothing) go = unpackCmd (names, Just ".") go +unpackCmd (names, Just dstPath) go = withConfigAndLock go $ do mSnapshotDef <- mapM (makeConcreteResolver Nothing >=> loadResolver) (globalResolver go) - Stack.Fetch.unpackPackages mSnapshotDef "." names + Stack.Fetch.unpackPackages mSnapshotDef (T.unpack dstPath) names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO () @@ -766,7 +778,7 @@ (ExecGhc, args) -> return ("ghc", args) (ExecRunGhc, args) -> return ("runghc", args) loadConfigWithOpts go $ \lc -> - withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> do + withUserFileLock go (view stackRootL lc) $ \lk -> do let getCompilerVersion = loadCompilerVersion go lc runRIO (lcConfig lc) $ Docker.reexecWithOptionalContainer @@ -775,42 +787,43 @@ (Just $ munlockFile lk) (runRIO (lcConfig lc) $ do config <- view configL - menv <- liftIO $ configEnvOverride config plainEnvSettings - Nix.reexecWithOptionalShell + menv <- liftIO $ configProcessContextSettings config plainEnvSettings + withProcessContext menv $ Nix.reexecWithOptionalShell (lcProjectRoot lc) getCompilerVersion (runRIO (lcConfig lc) $ - exec menv cmd args)) + exec cmd args)) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do - let targets = concatMap words eoPackages - unless (null targets) $ - Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI - { boptsCLITargets = map T.pack targets - } + let targets = concatMap words eoPackages + unless (null targets) $ + Stack.Build.build (const $ return ()) lk defaultBuildOptsCLI + { boptsCLITargets = map T.pack targets + } - config <- view configL - menv <- liftIO $ configEnvOverride config eoEnvSettings + config <- view configL + menv <- liftIO $ configProcessContextSettings config eoEnvSettings + withProcessContext menv $ do -- Add RTS options to arguments let argsWithRts args = if null eoRtsOptions then args :: [String] else args ++ ["+RTS"] ++ eoRtsOptions ++ ["-RTS"] (cmd, args) <- case (eoCmd, argsWithRts eoArgs) of (ExecCmd cmd, args) -> return (cmd, args) - (ExecGhc, args) -> getGhcCmd "" menv eoPackages args + (ExecGhc, args) -> getGhcCmd "" eoPackages args -- NOTE: this won't currently work for GHCJS, because it doesn't have -- a runghcjs binary. It probably will someday, though. (ExecRunGhc, args) -> - getGhcCmd "run" menv eoPackages args + getGhcCmd "run" eoPackages args munlockFile lk -- Unlock before transferring control away. - runWithPath eoCwd $ exec menv cmd args + runWithPath eoCwd $ exec cmd args where -- return the package-id of the first package in GHC_PACKAGE_PATH - getPkgId menv wc name = do - mId <- findGhcPkgField menv wc [] name "id" + getPkgId wc name = do + mId <- findGhcPkgField wc [] name "id" case mId of Just i -> return (head $ words (T.unpack i)) -- should never happen as we have already installed the packages @@ -818,13 +831,12 @@ hPutStrLn stderr ("Could not find package id of package " ++ name) exitFailure - getPkgOpts menv wc pkgs = do - ids <- mapM (getPkgId menv wc) pkgs - return $ map ("-package-id=" ++) ids + getPkgOpts wc pkgs = + map ("-package-id=" ++) <$> mapM (getPkgId wc) pkgs - getGhcCmd prefix menv pkgs args = do + getGhcCmd prefix pkgs args = do wc <- view $ actualCompilerVersionL.whichCompilerL - pkgopts <- getPkgOpts menv wc pkgs + pkgopts <- getPkgOpts wc pkgs return (prefix ++ compilerExeName wc, pkgopts ++ args) runWithPath :: Maybe FilePath -> RIO EnvConfig () -> RIO EnvConfig () @@ -872,7 +884,7 @@ dockerPullCmd _ go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer Docker.pull @@ -881,7 +893,7 @@ dockerResetCmd keepHome go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome @@ -890,7 +902,7 @@ dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = loadConfigWithOpts go $ \lc -> -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/? - withUserFileLock go (configStackRoot $ lcConfig lc) $ \_ -> + withUserFileLock go (view stackRootL lc) $ \_ -> runRIO (lcConfig lc) $ Docker.preventInContainer $ Docker.cleanup cleanupOpts @@ -928,7 +940,9 @@ newCmd (newOpts,initOpts) go@GlobalOpts{..} = withMiniConfigAndLock go $ do dir <- new newOpts (forceOverwrite initOpts) - initProject IsNewCmd dir initOpts globalResolver + exists <- doesFileExist $ dir stackDotYaml + when (forceOverwrite initOpts || not exists) $ + initProject IsNewCmd dir initOpts globalResolver -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO () @@ -944,19 +958,6 @@ -- | Visualize dependencies dotCmd :: DotOpts -> GlobalOpts -> IO () dotCmd dotOpts go = withBuildConfigDot dotOpts go $ dot dotOpts - --- | List the dependencies -listDependenciesCmd :: ListDepsOpts -> GlobalOpts -> IO () -listDependenciesCmd opts go = withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts - --- Plumbing for --test and --bench flags -withBuildConfigDot :: DotOpts -> GlobalOpts -> RIO EnvConfig () -> IO () -withBuildConfigDot opts go f = withBuildConfig go' f - where - go' = - (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $ - (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) - go -- | Query build information queryCmd :: [String] -> GlobalOpts -> IO () diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs --- a/src/test/Network/HTTP/Download/VerifiedSpec.hs +++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} module Network.HTTP.Download.VerifiedSpec where -import Control.Monad.Logger (runStdoutLoggingT) import Control.Retry (limitRetries) import Crypto.Hash import Network.HTTP.Client.Conduit @@ -67,8 +66,7 @@ let exampleProgressHook _ = return () describe "verifiedDownload" $ do - let run func = runStdoutLoggingT - $ withRunner LevelError True True ColorNever Nothing False + let run func = withRunner LevelError True True ColorNever Nothing False $ \runner -> runRIO runner func -- Preconditions: -- * the exampleReq server is running diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs --- a/src/test/Stack/Build/TargetSpec.hs +++ b/src/test/Stack/Build/TargetSpec.hs @@ -6,7 +6,7 @@ import qualified Data.Text as T import Stack.Build.Target import Stack.Prelude -import Stack.Types.Config +import Stack.Types.NamedComponent import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -35,6 +35,7 @@ " prefetch: true\n" ++ " force-dirty: true\n" ++ " keep-going: true\n" ++ + " keep-tmp-files: true\n" ++ " test: true\n" ++ " test-arguments:\n" ++ " rerun-tests: true\n" ++ @@ -117,6 +118,7 @@ boptsInstallExes `shouldBe` True boptsPreFetch `shouldBe` True boptsKeepGoing `shouldBe` Just True + boptsKeepTmpFiles `shouldBe` Just True boptsForceDirty `shouldBe` True boptsTests `shouldBe` True boptsTestOpts `shouldBe` TestOpts {toRerunTests = True diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs --- a/src/test/Stack/DotSpec.hs +++ b/src/test/Stack/DotSpec.hs @@ -20,7 +20,7 @@ import Stack.Dot dummyPayload :: DotPayload -dummyPayload = DotPayload (parseVersionFromString "0.0.0.0") (Just BSD3) +dummyPayload = DotPayload (parseVersionFromString "0.0.0.0") (Just (Right BSD3)) spec :: Spec spec = do diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs --- a/src/test/Stack/Ghci/ScriptSpec.hs +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -6,7 +6,6 @@ -- | Test suite for the GhciScript DSL module Stack.Ghci.ScriptSpec where -import Data.Monoid import qualified Data.Set as S import Distribution.ModuleName import Test.Hspec diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -1,14 +1,16 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Stack.NixSpec where +import Data.Maybe (fromJust) import Options.Applicative import Path +import Prelude (writeFile) import Stack.Config -import Stack.Options.NixParser import Stack.Config.Nix +import Stack.Constants +import Stack.Options.NixParser import Stack.Prelude import Stack.Types.Compiler import Stack.Types.Config @@ -18,8 +20,6 @@ import System.Directory import System.Environment import Test.Hspec -import Prelude (writeFile) -import Data.Maybe (fromJust) sampleConfigNixEnabled :: String sampleConfigNixEnabled = @@ -37,9 +37,6 @@ "nix:\n" ++ " enable: False" -stackDotYaml :: Path Rel File -stackDotYaml = $(mkRelFile "stack.yaml") - setup :: IO () setup = unsetEnv "STACK_YAML" @@ -62,6 +59,7 @@ (info (nixOptsParser False) mempty) cmdLineOpts parseOpts cmdLineOpts = mempty { configMonoidNixOpts = parseNixOpts cmdLineOpts } + let trueOnNonWindows = not osIsWindows describe "nix disabled in config file" $ around_ (withStackDotYaml sampleConfigNixDisabled) $ do it "sees that the nix shell is not enabled" $ do @@ -70,11 +68,11 @@ describe "--nix given on command line" $ it "sees that the nix shell is enabled" $ do lc <- loadConfig' (parseOpts ["--nix"]) - nixEnable (configNix $ lcConfig lc) `shouldBe` True + nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--nix-pure given on command line" $ it "sees that the nix shell is enabled" $ do lc <- loadConfig' (parseOpts ["--nix-pure"]) - nixEnable (configNix $ lcConfig lc) `shouldBe` True + nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix given on command line" $ it "sees that the nix shell is not enabled" $ do lc <- loadConfig' (parseOpts ["--no-nix"]) @@ -87,7 +85,7 @@ around_ (withStackDotYaml sampleConfigNixEnabled) $ do it "sees that the nix shell is enabled" $ do lc <- loadConfig' mempty - nixEnable (configNix $ lcConfig lc) `shouldBe` True + nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix given on command line" $ it "sees that the nix shell is not enabled" $ do lc <- loadConfig' (parseOpts ["--no-nix"]) @@ -95,11 +93,11 @@ describe "--nix-pure given on command line" $ it "sees that the nix shell is enabled" $ do lc <- loadConfig' (parseOpts ["--nix-pure"]) - nixEnable (configNix $ lcConfig lc) `shouldBe` True + nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows describe "--no-nix-pure given on command line" $ it "sees that the nix shell is enabled" $ do lc <- loadConfig' (parseOpts ["--no-nix-pure"]) - nixEnable (configNix $ lcConfig lc) `shouldBe` True + nixEnable (configNix $ lcConfig lc) `shouldBe` trueOnNonWindows it "sees that the only package asked for is glpk and asks for the correct GHC derivation" $ do lc <- loadConfig' mempty nixPackages (configNix $ lcConfig lc) `shouldBe` ["glpk"] diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -5,12 +5,10 @@ module Stack.PackageDumpSpec where import Data.Conduit -import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Text (decodeUtf8) import qualified Data.Map as Map import qualified Data.Set as Set -import Distribution.System (buildPlatform) import Distribution.License (License(..)) import Stack.PackageDump import Stack.Prelude @@ -19,7 +17,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import System.Process.Read +import RIO.Process import Test.Hspec import Test.Hspec.QuickCheck @@ -30,7 +28,7 @@ spec = do describe "eachSection" $ do let test name content expected = it name $ do - actual <- yield content $$ eachSection CL.consume =$ CL.consume + actual <- runConduit $ yield content .| eachSection CL.consume .| CL.consume actual `shouldBe` expected test "unix line endings" @@ -56,7 +54,7 @@ , " val4b" ] sink k = fmap (k, ) CL.consume - actual <- mapM_ yield bss $$ eachPair sink =$ CL.consume + actual <- runConduit $ mapM_ yield bss .| eachPair sink .| CL.consume actual `shouldBe` [ ("key1", ["val1"]) , ("key2", ["val2a", "val2b"]) @@ -66,11 +64,13 @@ describe "conduitDumpPackage" $ do it "ghc 7.8" $ do - haskell2010:_ <- runResourceT - $ CB.sourceFile "test/package-dump/ghc-7.8.txt" - =$= decodeUtf8 - $$ conduitDumpPackage - =$ CL.consume + haskell2010:_ <- + withSourceFile "test/package-dump/ghc-7.8.txt" $ \src -> + runConduit + $ src + .| decodeUtf8 + .| conduitDumpPackage + .| CL.consume ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a" packageIdent <- parsePackageIdentifier "haskell2010-1.1.2.0" depends <- mapM parseGhcPkgId @@ -81,6 +81,7 @@ haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = packageIdent + , dpParentLibIdent = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends @@ -96,11 +97,13 @@ } it "ghc 7.10" $ do - haskell2010:_ <- runResourceT - $ CB.sourceFile "test/package-dump/ghc-7.10.txt" - =$= decodeUtf8 - $$ conduitDumpPackage - =$ CL.consume + haskell2010:_ <- + withSourceFile "test/package-dump/ghc-7.10.txt" $ \src -> + runConduit + $ src + .| decodeUtf8 + .| conduitDumpPackage + .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3" pkgIdent <- parsePackageIdentifier "ghc-7.10.1" depends <- mapM parseGhcPkgId @@ -122,6 +125,7 @@ haskell2010 { dpExposedModules = [] } `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgIdent + , dpParentLibIdent = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"] , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] @@ -136,11 +140,13 @@ , dpExposedModules = [] } it "ghc 7.8.4 (osx)" $ do - hmatrix:_ <- runResourceT - $ CB.sourceFile "test/package-dump/ghc-7.8.4-osx.txt" - =$= decodeUtf8 - $$ conduitDumpPackage - =$ CL.consume + hmatrix:_ <- + withSourceFile "test/package-dump/ghc-7.8.4-osx.txt" $ \src -> + runConduit + $ src + .| decodeUtf8 + .| conduitDumpPackage + .| CL.consume ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe" pkgId <- parsePackageIdentifier "hmatrix-0.16.1.5" depends <- mapM parseGhcPkgId @@ -156,6 +162,7 @@ hmatrix `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId + , dpParentLibIdent = Nothing , dpLicense = Just BSD3 , dpLibDirs = [ "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/lib/x86_64-osx-ghc-7.8.4/hmatrix-0.16.1.5" @@ -174,11 +181,13 @@ , 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 - $ CB.sourceFile "test/package-dump/ghc-head.txt" - =$= decodeUtf8 - $$ conduitDumpPackage - =$ CL.consume + ghcBoot:_ <- + withSourceFile "test/package-dump/ghc-head.txt" $ \src -> + runConduit + $ src + .| decodeUtf8 + .| conduitDumpPackage + .| CL.consume ghcPkgId <- parseGhcPkgId "ghc-boot-0.0.0.0" pkgId <- parsePackageIdentifier "ghc-boot-0.0.0.0" depends <- mapM parseGhcPkgId @@ -191,6 +200,7 @@ ghcBoot `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId , dpPackageIdent = pkgId + , dpParentLibIdent = Nothing , dpLicense = Just BSD3 , dpLibDirs = ["/opt/ghc/head/lib/ghc-7.11.20151213/ghc-boot-0.0.0.0"] @@ -207,32 +217,29 @@ } - it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLogging $ do - menv' <- getEnvOverride buildPlatform - menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' + it "ghcPkgDump + addProfiling + addHaddock" $ runEnvNoLogging $ do icache <- newInstalledCache - ghcPkgDump menv Ghc [] + ghcPkgDump Ghc [] $ conduitDumpPackage - =$ addProfiling icache - =$ addHaddock icache - =$ fakeAddSymbols - =$ CL.sinkNull + .| addProfiling icache + .| addHaddock icache + .| fakeAddSymbols + .| CL.sinkNull - it "sinkMatching" $ do - menv' <- getEnvOverride buildPlatform - menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' + it "sinkMatching" $ runEnvNoLogging $ do icache <- newInstalledCache - m <- runNoLogging $ ghcPkgDump menv Ghc [] + m <- ghcPkgDump Ghc [] $ conduitDumpPackage - =$ addProfiling icache - =$ addHaddock icache - =$ fakeAddSymbols - =$ sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) + .| addProfiling icache + .| addHaddock icache + .| fakeAddSymbols + .| sinkMatching False False False (Map.singleton $(mkPackageName "transformers") $(mkVersion "0.0.0.0.0.0.1")) case Map.lookup $(mkPackageName "base") m of Nothing -> error "base not present" Just _ -> return () - Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing - Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing + liftIO $ do + Map.lookup $(mkPackageName "transformers") m `shouldBe` Nothing + Map.lookup $(mkPackageName "ghc") m `shouldBe` Nothing describe "pruneDeps" $ do it "sanity check" $ do @@ -276,5 +283,11 @@ Just deps -> Set.null $ Set.difference (Set.fromList deps) allIds -- addSymbols can't be reasonably tested like this -fakeAddSymbols :: Monad m => Conduit (DumpPackage a b c) m (DumpPackage a b Bool) +fakeAddSymbols :: Monad m => ConduitM (DumpPackage a b c) (DumpPackage a b Bool) m () fakeAddSymbols = CL.map (\dp -> dp { dpSymbols = False }) + +runEnvNoLogging :: RIO LoggedProcessContext a -> IO a +runEnvNoLogging inner = do + envVars <- view envVarsL <$> mkDefaultProcessContext + menv <- mkProcessContext $ Map.delete "GHC_PACKAGE_PATH" envVars + runRIO (LoggedProcessContext menv mempty) inner diff --git a/src/test/Stack/Types/BuildPlanSpec.hs b/src/test/Stack/Types/BuildPlanSpec.hs new file mode 100644 --- /dev/null +++ b/src/test/Stack/Types/BuildPlanSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.BuildPlanSpec where + +import Data.Aeson.Extended (WithJSONWarnings(..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.Yaml (decode) +import Stack.Types.BuildPlan +import Test.Hspec + +spec :: Spec +spec = + describe "PackageLocation" $ do + describe "Archive" $ do + describe "github" $ do + let decode' :: ByteString -> Maybe (WithJSONWarnings (PackageLocation Subdirs)) + decode' = decode + + it "'github' and 'commit' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + ]) + let expected :: PackageLocation Subdirs + expected = + PLArchive Archive + { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz" + , archiveSubdirs = DefaultSubdirs + , archiveHash = Nothing + } + decode' contents `shouldBe` Just (WithJSONWarnings expected []) + + it "'github', 'commit', and 'subdirs' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + , "subdirs:" + , " - foo" + ]) + let expected :: PackageLocation Subdirs + expected = + PLArchive Archive + { archiveUrl = "https://github.com/oink/town/archive/abc123.tar.gz" + , archiveSubdirs = ExplicitSubdirs ["foo"] + , archiveHash = Nothing + } + decode' contents `shouldBe` Just (WithJSONWarnings expected []) + + it "does not parse GitHub repo with no slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink" + , "commit: abc123" + ]) + decode' contents `shouldBe` Nothing + + it "does not parse GitHub repo with leading slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: /oink" + , "commit: abc123" + ]) + decode' contents `shouldBe` Nothing + + it "does not parse GitHub repo with trailing slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/" + , "commit: abc123" + ]) + decode' contents `shouldBe` Nothing + + it "does not parse GitHub repo with more than one slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town/here" + , "commit: abc123" + ]) + decode' contents `shouldBe` Nothing diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: fb527fd6f73c61ffd0b8055991e9f777b12c9a6790e5939a1e46edc260201513 +-- hash: 5b3e8d70c3e492d9cc4473a5919b80ee0fc2f59d6eb81b898d2bb507a83159e1 name: stack -version: 1.6.5 +version: 1.7.1 synopsis: The Haskell Tool Stack description: Please see the README.md for usage information, and the wiki on Github for more details. Also, note that the API for the library is not currently stable, and may change significantly, even between minor releases. It is currently only intended for use by the executable. category: Development @@ -16,8 +16,7 @@ license: BSD3 license-file: LICENSE build-type: Custom -cabal-version: >= 1.10 - +cabal-version: >= 1.24 extra-source-files: ChangeLog.md CONTRIBUTING.md @@ -43,7 +42,6 @@ doc/stack_yaml_vs_cabal_package_file.md doc/travis_ci.md doc/yaml_configuration.md - package.yaml README.md src/setup-shim/StackSetupShim.hs stack.yaml @@ -58,7 +56,7 @@ custom-setup setup-depends: Cabal - , base + , base >=4.10 && <5 , filepath flag disable-git-info @@ -87,109 +85,6 @@ default: False library - hs-source-dirs: - src/ - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities - build-depends: - Cabal - , aeson - , annotated-wl-pprint - , ansi-terminal - , async - , attoparsec - , base >=4.9 && <5 - , base64-bytestring - , blaze-builder - , bytestring - , clock - , conduit - , conduit-extra - , containers - , cryptonite - , cryptonite-conduit - , deepseq - , directory - , echo - , exceptions - , extra - , fast-logger - , file-embed - , filelock - , filepath - , fsnotify - , generic-deriving - , hackage-security - , hashable - , hastache - , hpack - , hpc - , http-client - , http-client-tls - , http-conduit - , http-types - , memory - , microlens - , microlens-mtl - , mintty - , monad-logger - , mono-traversable - , mtl - , neat-interpolation - , network-uri - , open-browser - , optparse-applicative - , path - , path-io - , persistent - , persistent-sqlite - , persistent-template - , pretty - , primitive - , process - , project-template - , regex-applicative-text - , resourcet - , retry - , semigroups - , split - , stm - , store - , store-core - , streaming-commons - , tar - , template-haskell - , temporary - , text - , text-metrics - , th-reify-many - , time - , tls - , transformers - , unicode-transforms - , unix-compat - , unliftio - , unordered-containers - , vector - , yaml - , zip-archive - , zlib - if os(windows) - cpp-options: -DWINDOWS - build-depends: - Win32 - else - build-depends: - bindings-uname - , pid1 - , unix - build-tools: - hsc2hs - if os(windows) - hs-source-dirs: - src/windows/ - else - hs-source-dirs: - src/unix/ exposed-modules: Control.Concurrent.Execute Data.Aeson.Extended @@ -200,6 +95,7 @@ Data.Store.VersionTagged Network.HTTP.Download Network.HTTP.Download.Verified + Network.HTTP.StackClient Options.Applicative.Args Options.Applicative.Builder.Extra Options.Applicative.Complicated @@ -229,7 +125,6 @@ Stack.Docker Stack.Docker.GlobalDB Stack.Dot - Stack.Exec Stack.Fetch Stack.FileWatch Stack.GhcPkg @@ -239,6 +134,7 @@ Stack.IDE Stack.Image Stack.Init + Stack.Ls Stack.New Stack.Nix Stack.Options.BenchParser @@ -296,6 +192,7 @@ Stack.Types.FlagName Stack.Types.GhcPkgId Stack.Types.Image + Stack.Types.NamedComponent Stack.Types.Nix Stack.Types.Package Stack.Types.PackageDump @@ -311,20 +208,121 @@ Stack.Upgrade Stack.Upload Text.PrettyPrint.Leijen.Extended - System.Process.Log System.Process.PagerEditor - System.Process.Read - System.Process.Run System.Terminal other-modules: Hackage.Security.Client.Repository.HttpLib.HttpClient + hs-source-dirs: + src/ + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-identities + build-depends: + Cabal + , aeson + , annotated-wl-pprint + , ansi-terminal + , async + , attoparsec + , base >=4.10 && <5 + , base64-bytestring + , bytestring + , conduit + , conduit-extra >=1.2.3.1 + , containers + , cryptonite + , cryptonite-conduit + , deepseq + , directory + , echo + , exceptions + , extra + , file-embed + , filelock + , filepath + , fsnotify + , generic-deriving + , hackage-security + , hashable + , hpack + , hpc + , http-client + , http-client-tls + , http-conduit + , http-types + , memory + , microlens + , mintty + , monad-logger + , mono-traversable + , mtl + , mustache + , neat-interpolation + , network-uri + , open-browser + , optparse-applicative + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , pretty + , primitive + , process + , project-template + , regex-applicative-text + , resourcet + , retry + , rio + , semigroups + , split + , stm + , store + , store-core + , streaming-commons + , tar + , template-haskell + , temporary + , text + , text-metrics + , th-reify-many + , time + , tls + , transformers + , typed-process >=0.2.1.0 + , unicode-transforms + , unix-compat + , unliftio >=0.2.4.0 + , unordered-containers + , vector + , yaml + , zip-archive + , zlib + if os(windows) + cpp-options: -DWINDOWS + build-depends: + Win32 + else + build-depends: + bindings-uname + , unix + build-tools: + hsc2hs + if os(windows) + hs-source-dirs: + src/windows/ + else + hs-source-dirs: + src/unix/ default-language: Haskell2010 + autogen-modules: Paths_stack executable stack main-is: Main.hs + other-modules: + Build_stack + Paths_stack hs-source-dirs: src/main - ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded -rtsopts build-depends: Cabal , aeson @@ -332,13 +330,11 @@ , ansi-terminal , async , attoparsec - , base >=4.9 && <5 + , base >=4.10 && <5 , base64-bytestring - , blaze-builder , bytestring - , clock , conduit - , conduit-extra + , conduit-extra >=1.2.3.1 , containers , cryptonite , cryptonite-conduit @@ -347,7 +343,6 @@ , echo , exceptions , extra - , fast-logger , file-embed , filelock , filepath @@ -355,7 +350,6 @@ , generic-deriving , hackage-security , hashable - , hastache , hpack , hpc , http-client @@ -364,11 +358,11 @@ , http-types , memory , microlens - , microlens-mtl , mintty , monad-logger , mono-traversable , mtl + , mustache , neat-interpolation , network-uri , open-browser @@ -385,6 +379,7 @@ , regex-applicative-text , resourcet , retry + , rio , semigroups , split , stack @@ -401,9 +396,10 @@ , time , tls , transformers + , typed-process >=0.2.1.0 , unicode-transforms , unix-compat - , unliftio + , unliftio >=0.2.4.0 , unordered-containers , vector , yaml @@ -416,7 +412,6 @@ else build-depends: bindings-uname - , pid1 , unix build-tools: hsc2hs @@ -431,13 +426,17 @@ cpp-options: -DHIDE_DEP_VERSIONS if flag(supported-build) cpp-options: -DSUPPORTED_BUILD - other-modules: - Paths_stack default-language: Haskell2010 + autogen-modules: + Build_stack, + Paths_stack test-suite stack-integration-test type: exitcode-stdio-1.0 main-is: IntegrationSpec.hs + other-modules: + StackTest + Paths_stack hs-source-dirs: test/integration test/integration/lib @@ -449,13 +448,11 @@ , ansi-terminal , async , attoparsec - , base >=4.9 && <5 + , base >=4.10 && <5 , base64-bytestring - , blaze-builder , bytestring - , clock , conduit - , conduit-extra + , conduit-extra >=1.2.3.1 , containers , cryptonite , cryptonite-conduit @@ -464,7 +461,6 @@ , echo , exceptions , extra - , fast-logger , file-embed , filelock , filepath @@ -472,7 +468,6 @@ , generic-deriving , hackage-security , hashable - , hastache , hpack , hpc , hspec @@ -482,11 +477,11 @@ , http-types , memory , microlens - , microlens-mtl , mintty , monad-logger , mono-traversable , mtl + , mustache , neat-interpolation , network-uri , open-browser @@ -503,6 +498,7 @@ , regex-applicative-text , resourcet , retry + , rio , semigroups , split , stm @@ -518,9 +514,10 @@ , time , tls , transformers + , typed-process >=0.2.1.0 , unicode-transforms , unix-compat - , unliftio + , unliftio >=0.2.4.0 , unordered-containers , vector , yaml @@ -533,20 +530,35 @@ else build-depends: bindings-uname - , pid1 , unix build-tools: hsc2hs if !(flag(integration-tests)) buildable: False - other-modules: - StackTest - Paths_stack default-language: Haskell2010 test-suite stack-test type: exitcode-stdio-1.0 main-is: Test.hs + other-modules: + Network.HTTP.Download.VerifiedSpec + Spec + Stack.ArgsSpec + Stack.Build.ExecuteSpec + Stack.Build.TargetSpec + Stack.ConfigSpec + Stack.DotSpec + Stack.Ghci.PortableFakePaths + Stack.Ghci.ScriptSpec + Stack.GhciSpec + Stack.NixSpec + Stack.PackageDumpSpec + Stack.SolverSpec + Stack.StaticBytesSpec + Stack.StoreSpec + Stack.Types.BuildPlanSpec + Stack.Untar.UntarSpec + Paths_stack hs-source-dirs: src/test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded @@ -558,13 +570,11 @@ , ansi-terminal , async , attoparsec - , base >=4.9 && <5 + , base >=4.10 && <5 , base64-bytestring - , blaze-builder , bytestring - , clock , conduit - , conduit-extra + , conduit-extra >=1.2.3.1 , containers , cryptonite , cryptonite-conduit @@ -573,7 +583,6 @@ , echo , exceptions , extra - , fast-logger , file-embed , filelock , filepath @@ -581,7 +590,6 @@ , generic-deriving , hackage-security , hashable - , hastache , hpack , hpc , hspec @@ -591,11 +599,11 @@ , http-types , memory , microlens - , microlens-mtl , mintty , monad-logger , mono-traversable , mtl + , mustache , neat-interpolation , network-uri , open-browser @@ -612,6 +620,7 @@ , regex-applicative-text , resourcet , retry + , rio , semigroups , smallcheck , split @@ -629,9 +638,10 @@ , time , tls , transformers + , typed-process >=0.2.1.0 , unicode-transforms , unix-compat - , unliftio + , unliftio >=0.2.4.0 , unordered-containers , vector , yaml @@ -644,26 +654,7 @@ else build-depends: bindings-uname - , pid1 , unix build-tools: hsc2hs - other-modules: - Network.HTTP.Download.VerifiedSpec - Spec - Stack.ArgsSpec - Stack.Build.ExecuteSpec - Stack.Build.TargetSpec - Stack.ConfigSpec - Stack.DotSpec - Stack.Ghci.PortableFakePaths - Stack.Ghci.ScriptSpec - Stack.GhciSpec - Stack.NixSpec - Stack.PackageDumpSpec - Stack.SolverSpec - Stack.StaticBytesSpec - Stack.StoreSpec - Stack.Untar.UntarSpec - Paths_stack default-language: Haskell2010 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ -resolver: lts-9.14 +resolver: lts-11.6 + # docker: # enable: true # repo: fpco/stack-full @@ -11,25 +12,22 @@ enable: false packages: - zlib + - unzip flags: stack: hide-dependency-versions: true supported-build: true - mintty: - win32-2-5: false extra-deps: -- Cabal-2.0.1.0 -- mintty-0.1.1 -- bindings-uname-0.1 -- path-0.6.1 -- path-io-1.3.3 -- extra-1.6 -- hsc2hs-0.68.2 -- hpack-0.20.0 -- unliftio-0.2.1.0 -- ansi-terminal-0.7.1.1 -- ansi-wl-pprint-0.6.8.1 -- smallcheck-1.1.3 -- archive: https://github.com/haskell/hackage-security/archive/3297b0f3f4285cb30321baaa7b54e3d22e1f6bd7.tar.gz - subdirs: - - hackage-security +- rio-0.1.1.0@rev:0 +- Cabal-2.2.0.1@rev:0 +- hpack-0.28.2 +- http-api-data-0.3.8.1@rev:0 + +# Avoid https://github.com/commercialhaskell/stack/issues/3922 +# (triggered because later versions of persistent transitively depends +# on haskell-src-exts, which needs the 'happy' build tool) +- persistent-2.7.1@rev:0 +- persistent-sqlite-2.6.4@rev:0 +- resourcet-1.1.11@rev:0 +- conduit-1.2.13@rev:0 +- conduit-extra-1.2.3.2@rev:0 diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -79,7 +79,7 @@ when newHomeExists (removeDirectoryRecursive newHome) createDirectoryIfMissing True newStackRoot copyTree toCopyRoot origStackRoot newStackRoot - writeFile (newStackRoot "config.yaml") "system-ghc: true" + writeFile (newStackRoot "config.yaml") "system-ghc: true\ninstall-ghc: false\n" let testDir = currDir "tests" name mainFile = testDir "Main.hs" libDir = currDir "lib" diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -205,11 +205,10 @@ -- | To avoid problems with GHC version mismatch when a new LTS major -- version is released, pass this argument to @stack@ when running in -- a global context. The LTS major version here should match that of --- the main @stack.yaml@ (and ordinarily be the `.0` minor version). +-- the main @stack.yaml@. -- --- NOTE: currently using lts-8.22 instead of lts-8.0 because the `cyclic-test-deps` integration test is broken with lts-8.0 because a hackage metadata revision invalidated the snapshot (snapshot has `test-framework-quickcheck2-0.3.0.3` and `QuickCheck-2.9.2`, which used to be fine, but now test-framework-quickcheck2 was revised to have a `QuickCheck < 2.8` constraint). defaultResolverArg :: String -defaultResolverArg = "--resolver=lts-8.22" +defaultResolverArg = "--resolver=lts-11.6" -- | Remove a file and ignore any warnings about missing files. removeFileIgnore :: FilePath -> IO ()