diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,126 +1,143 @@ -# Changelog for pantry - -## v0.5.6 - -* Remove operational and mirror keys from bootstrap key set [#53](https://github.com/commercialhaskell/pantry/pull/53) - -## v0.5.5 - -* Support Cabal 3.6 - -## v0.5.4 - -* Support aeson 2 - -## v0.5.3 - -* improve and expose `fetchRepos`/`fetchReposRaw` - -## v0.5.2.3 - -* Support for GHC 9 [#39](https://github.com/commercialhaskell/pantry/pull/39) - -## v0.5.2.2 - -* Support for Cabal 3.4 [#38](https://github.com/commercialhaskell/pantry/pull/38) - -## v0.5.2.1 - -* Support persistent 2.13 [#35](https://github.com/commercialhaskell/pantry/issues/35) - -## v0.5.2 - -* Fall back to BSD tar when type cannot be detected [#33](https://github.com/commercialhaskell/pantry/issues/33) - -## v0.5.1.5 -* Switch back to hackage.haskell.org [#30](https://github.com/commercialhaskell/pantry/pull/30) -* Pass through basic auth credentials specified in URLs [#32](https://github.com/commercialhaskell/pantry/pull/32) - -## v0.5.1.4 - -* Allow building with persistent-2.11 [#28](https://github.com/commercialhaskell/pantry/pull/28) - -## v0.5.1.3 - -* Handle case where tree exists in cache by blobs are missing [#27](https://github.com/commercialhaskell/pantry/issues/27) - -## v0.5.1.2 - -* Skip a test for [#26](https://github.com/commercialhaskell/pantry/issues/26) - -## v0.5.1.1 - -* Fix to allow mulitiple relative path of symlink. - -## v0.5.1.0 - -* Catch all exceptions from Casa calls and recover - -## v0.5.0.0 - -* Make the location of LTS/Nightly snapshots configurable - -## v0.4.0.1 - -* Removed errant log message - -## v0.4.0.0 - -* Add a deprecation warning when using a repo/archive without a cabal file, see [Stack #5210](https://github.com/commercialhaskell/stack/issues/5210) -* Do not include repo/archive dependencies which do not include cabal files in lock files -* Remove some no longer used functions - -## v0.3.0.0 - -* Upgrade to Cabal 3.0 - -## v0.2.0.0 - -Bug fixes: - -* Don't compare the hashes of cabal files. - Addresses bugs such as [Stack - #5045](https://github.com/commercialhaskell/stack/issues/5045). - Data type changes: removed the `pmCabal` and `rpmCabal` fields. - -## v0.1.1.2 - -Bug fixes: - -* Module mapping insertions into the database are now atomic. Previously, if - you SIGTERMed at the wrong time while running a script, you could end up with - an inconsistent database state. - -## v0.1.1.1 - -Other changes: - -* Support building with persistent-template-2.7 - - -## v0.1.1.0 - -**Changes since 0.1.0.0** - -Bug fixes: - -* Fix to allow dependencies on specific versions of local git repositories. See - [#4862](https://github.com/commercialhaskell/stack/pull/4862) - -Behavior changes: - -* By default, do not perform expiry checks in Hackage Security. See - - [#4928](https://github.com/commercialhaskell/stack/issues/4928). - -Other changes: - -* Rename `pantry-tmp` package back to `pantry`, now that we have gained - maintainership (which had been used by someone else for a candidate-only test - that made it look like the name was free but prevented uploading a real - package). - - -## 0.1.0.0 - -* Initial release +# Changelog for pantry + +## v0.5.7 + +* Expose `loadAndCompleteSnapshotRaw'` and `loadAndCompleteSnapshot'`, which + allow the toggling of the debug output of the raw snapshot layer. See + [#55](https://github.com/commercialhaskell/pantry/pull/55). +* Support GHC 9.4. + +## v0.5.6 + +* Remove operational and mirror keys from bootstrap key set. See + [#53](https://github.com/commercialhaskell/pantry/pull/53). + +## v0.5.5 + +* Support `Cabal-3.6.0.0`. + +## v0.5.4 + +* Support `aeson-2.0.0.0`. + +## v0.5.3 + +* improve and expose `fetchRepos`/`fetchReposRaw`. + +## v0.5.2.3 + +* Support for GHC 9.0. See + [#39](https://github.com/commercialhaskell/pantry/pull/39). + +## v0.5.2.2 + +* Support for `Cabal-3.4.0.0`. See + [#38](https://github.com/commercialhaskell/pantry/pull/38). + +## v0.5.2.1 + +* Support `persistent-2.13.0.0`. See + [#35](https://github.com/commercialhaskell/pantry/issues/35). + +## v0.5.2 + +* Fall back to BSD tar when type cannot be detected. See + [#33](https://github.com/commercialhaskell/pantry/issues/33). + +## v0.5.1.5 +* Switch back to `hackage.haskell.org`. See + [#30](https://github.com/commercialhaskell/pantry/pull/30). +* Pass through basic auth credentials specified in URLs. See + [#32](https://github.com/commercialhaskell/pantry/pull/32). + +## v0.5.1.4 + +* Allow building with `persistent-2.11.0.0`. See + [#28](https://github.com/commercialhaskell/pantry/pull/28). + +## v0.5.1.3 + +* Handle case where tree exists in cache by blobs are missing. See + [#27](https://github.com/commercialhaskell/pantry/issues/27). + +## v0.5.1.2 + +* Skip a test for issue + [#26](https://github.com/commercialhaskell/pantry/issues/26). + +## v0.5.1.1 + +* Fix to allow multiple relative path of symlink. + +## v0.5.1.0 + +* Catch all exceptions from Casa calls and recover. + +## v0.5.0.0 + +* Make the location of LTS/Nightly snapshots configurable. + +## v0.4.0.1 + +* Removed errant log message. + +## v0.4.0.0 + +* Add a deprecation warning when using a repo/archive without a Cabal file, see + Stack issue [#5210](https://github.com/commercialhaskell/stack/issues/5210). +* Do not include repo/archive dependencies which do not include Cabal files in + lock files. +* Remove some no longer used functions. + +## v0.3.0.0 + +* Upgrade to `Cabal-3.0.0.0`. + +## v0.2.0.0 + +Bug fixes: + +* Don't compare the hashes of Cabal files. Addresses bugs such as Stack issue + [#5045](https://github.com/commercialhaskell/stack/issues/5045). Data type + changes: removed the `pmCabal` and `rpmCabal` fields. + +## v0.1.1.2 + +Bug fixes: + +* Module mapping insertions into the database are now atomic. Previously, if + you SIGTERMed at the wrong time while running a script, you could end up with + an inconsistent database state. + +## v0.1.1.1 + +Other changes: + +* Support building with `persistent-template-2.7.0`. + +## v0.1.1.0 + +**Changes since 0.1.0.0** + +Bug fixes: + +* Fix to allow dependencies on specific versions of local git repositories. See + Stack pull request + [#4862](https://github.com/commercialhaskell/stack/pull/4862). + +Behavior changes: + +* By default, do not perform expiry checks in Hackage Security. See Stack issue + [#4928](https://github.com/commercialhaskell/stack/issues/4928). + +Other changes: + +* Rename `pantry-tmp` package back to `pantry`, now that we have gained + maintainership (which had been used by someone else for a candidate-only test + that made it look like the name was free but prevented uploading a real + package). + + +## 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,24 +1,24 @@ -Copyright (c) 2015-2019, Stack contributors -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of Stack nor the - names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015-2022, Stack contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Stack nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,217 +1,217 @@ -# pantry - -[![Build Status](https://dev.azure.com/commercialhaskell/pantry/_apis/build/status/commercialhaskell.pantry?branchName=master)](https://dev.azure.com/commercialhaskell/pantry/_build/latest?definitionId=6&branchName=master) - -Content addressable Haskell package management, providing for secure, -reproducible acquisition of Haskell package contents and metadata. - -## What is Pantry - -* A Haskell library, storage specification, and network protocol -* Intended for content-addressable storage of Haskell packages -* Allows non-centralized package storage -* Primarily for use by Stackage and Stack, hopefully other tools as well - -## Goals - -* Efficient, distributed package storage for Haskell -* Superset of existing storage mechanisms -* Security via content addressable storage -* Allow more Stackage-style snapshots to exist -* Allow authors to bypass Hackage for uploads -* Allow Stackage to create forks of packages on Hackage - -__TODO__ - -Content below needs to be updated. - -* Support for hpack in PackageLocationImmutable? - -## Package definition - -Pantry defines the following concepts: - -* __Blob__: a raw byte sequence, identified by its key (SHA256 of the - contents) -* __Tree entry__: contents of a single file (identified by blob key) - and whether or not it is executable. - * NOTE: existing package formats like tarballs support more - sophisticated options. We explicitly do not support those. If - such functionality is needed, fallback to those mechanism is - required. -* __Tree__: mapping from relative path to a tree entry. Some basic - sanity rules apply to the paths: no `.` or `..` directory - components, no newlines in filepaths, does not begin with `/`, no - `\\` (we normalize to POSIX-style paths). A tree is identified by a - tree key (SHA256 of the tree's serialized format). -* __Package__: a tree key for the package contents, package name, - version number, and cabal file blob key. Requirements: there must be - a single file with a `.cabal` file extension at the root of the - tree, and it must match the cabal file blob key. The cabal file must - be located at `pkgname.cabal`. Each tree can be in at most one - package, and therefore tree keys work as package keys too. - -Note that with the above, a tree key is all the information necessary -to uniquely identify a package. However, including additional -information (package name, version, cabal key) in config files may be -useful for optimizations or user friendliness. If such extra -information is ever included, it must be validated to concur with the -package contents itself. - -### Package location - -Packages will optionally be sourced from some location: - -* __Hackage__ requires the package name, version number, and revision - number. Each revision of a package will end up with a different tree - key. -* __Archive__ takes a URL pointing to a tarball (gzipped or not) or a - ZIP file. An implicit assumption is that archives remain immutable - over time. Use tree keys to verify this assumption. (Same applies to - Hackage for that matter.) -* __Repository__ takes a repo type (Git or Mercurial), URL, and - commit. Assuming the veracity of the cryptographic hashes on the - repos, this should guarantee a unique set of files. - -In order to deal with _megarepos_ (repos and archives containing more -than one package), there is also a subdirectory for the archive and -repository cases. An empty subdir `""` would be the case for a -standard repo/archive. - -In order to meet the rules of a package listed above, the following -logic is applied to all three types above: - -* Find all of the files in the raw location, and represent as `Map - FilePath TreeEntry` (or equivalent). -* Remove a wrapper directory. If _all_ filepaths in that `Map` are - contained within the same directory, strip it from all of the - paths. For example, if the paths are `foo/bar` and `foo/baz`, the - paths will be reduced to `bar` and `baz`. -* After this wrapper is removed, then subdirectory logic is applied, - essentially applying `stripPrefix` to the filepaths. If the subdir - is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` - and `yesod-bin/yesod-bin.cabal`, the only file remaining after - subdir stripping would be `yesod-bin.cabal`. Note that trailing - slashes must be handled appropriately, and that an empty subdir - string results in this step being a noop. - -The result of all of this is that, given one of the three package -locations above, we can receive a tree key which will provide an -installable package. That tree key will remain immutable. - -### How tooling refers to packages - -We'll get to the caching mechanism for Pantry below. However, the -recommended approach for tooling is to support some kind of composite -of the Pantry keys, parsed info, and raw package location. This allows -for more efficient lookups when available, with a fallback when -mirrors don't have the needed information. - -An example: - -```yaml -extra-deps: -- name: foobar - version: 1.2.3.4 - pantry: deadbeef # tree key - cabal-file: 12345678 # blob key - archive: https://example.com/foobar-1.2.3.4.tar.gz -``` - -It is also recommended that tooling provide an easy way to generate -such complete information from, e.g., just the URL of the tarball, and -that upon reading information, hashes, package names, and version -numbers are all checked for correctness. - -## Pantry caching - -One simplistic option for Pantry would be that, every time a piece of -data is needed, Pantry downloads the necessary tarball/Git -repo/etc. However, this would in practice be highly wasteful, since -downloading Git repos and archives just to get a single cabal file -(for plan construction purposes) is overkill. Instead, here's the -basic idea for how caching works: - -* All data for Pantry can be stored in a SQL database. Local tools - like Stack will use an SQLite database. Servers will use PostgreSQL. -* We'll define a network protocol (initially just HTTP, maybe - extending to something more efficient if desired) for querying blobs - and trees. -* When a blob or tree is needed, it is first checked for in the local - SQLite cache. If it's not available there, a request to the Pantry - mirrors (configurable) will be made for the data. Since everything - is content addressable, it is safe to use untrusted mirrors. -* If the data is not available in a mirror, and a location is - provided, the location will be downloaded and cached locally. - -We may also allow these Pantry mirrors to provide some kind of query -interface to find out, e.g., the latest version of a package on -Hackage. That's still TBD. - -## Example: resolving a package location - -To work through a full example, the following three stanzas are intended to -have equivalent behavior: - -```yaml -- archive: https://example.com/foobar-1.2.3.4.tar.gz - -- name: foobar - version: 1.2.3.4 - pantry: deadbeef # tree key - cabal-file: 12345678 # blob key - archive: https://example.com/foobar-1.2.3.4.tar.gz - -- pantry: deadbeef - -``` - -The question is: how does the first one (presumably what a user would want to -enter) be resolved into the second and third? Pantry would follow this set of -steps: - -* Download the tarball from the given URL -* Place each file in the tarball into its store as a blob, getting a blob key - for each. The tarball is now represented as `Map FilePath BlobKey` -* Perform the root directory stripping step, removing a shared path -* Since there's no subdirectory: no subdirectory stripping would be performed -* Serialize the `Map FilePath BlobKey` to a binary format and take its hash to - get a tree key -* Store the tree in the store referenced by its tree key. In our example: the - tree key is `deadbeef`. -* Ensure that the tree is a valid package by checking for a single cabal file - at the root. In our example, that's found in `foobar.cabal` with blob key - `12345678`. -* Parse the cabal file and ensure that it is a valid cabal file, and that its - package name is `foobar`. Grab the version number (1.2.3.4). -* We now know that tree key `deadbeef` is a valid package, and can refer to it - by tree key exclusively. However, including the other information allows us - to verify our assumptions, provide user-friendly readable data, and provide a - fallback if the package isn't in the Pantry cache. - -## More advanced content discovery - -There are three more advanced cases to consider: - -* Providing fall-back locations for content, such as out of concern for a - single URL being removed in the future -* Closed corporate setups, where access to the general internet may either be - impossible or undesirable -* Automatic discovery of missing content by hash - -The following extensions are possible to address these cases: - -* Instead of a single package location, provide a list of package locations - with fallback semantics. -* Corporate environments will be encouraged to run a local Pantry mirror, and - configure clients like Stack to speak to these mirrors instead of the default - ones (or in addition to). -* Provide some kind of federation protocol for Pantry where servers can - registry with each other and requests for content can be pinged to each - other. - -Providing override at the client level for Pantry mirror locations is a -__MUST__. Making it easy to run in a corporate environment is a __SHOULD__. -Providing the fallback package locations seems easy enough that we should -include it initially, but falls under a __SHOULD__. The federated protocol -should be added on-demand. +# pantry + +[![Build Status](https://dev.azure.com/commercialhaskell/pantry/_apis/build/status/commercialhaskell.pantry?branchName=master)](https://dev.azure.com/commercialhaskell/pantry/_build/latest?definitionId=6&branchName=master) + +Content addressable Haskell package management, providing for secure, +reproducible acquisition of Haskell package contents and metadata. + +## What is Pantry + +* A Haskell library, storage specification, and network protocol +* Intended for content-addressable storage of Haskell packages +* Allows non-centralized package storage +* Primarily for use by Stackage and Stack, hopefully other tools as well + +## Goals + +* Efficient, distributed package storage for Haskell +* Superset of existing storage mechanisms +* Security via content addressable storage +* Allow more Stackage-style snapshots to exist +* Allow authors to bypass Hackage for uploads +* Allow Stackage to create forks of packages on Hackage + +__TODO__ + +Content below needs to be updated. + +* Support for hpack in PackageLocationImmutable? + +## Package definition + +Pantry defines the following concepts: + +* __Blob__: a raw byte sequence, identified by its key (SHA256 of the + contents) +* __Tree entry__: contents of a single file (identified by blob key) + and whether or not it is executable. + * NOTE: existing package formats like tarballs support more + sophisticated options. We explicitly do not support those. If + such functionality is needed, fallback to those mechanism is + required. +* __Tree__: mapping from relative path to a tree entry. Some basic + sanity rules apply to the paths: no `.` or `..` directory + components, no newlines in filepaths, does not begin with `/`, no + `\\` (we normalize to POSIX-style paths). A tree is identified by a + tree key (SHA256 of the tree's serialized format). +* __Package__: a tree key for the package contents, package name, + version number, and cabal file blob key. Requirements: there must be + a single file with a `.cabal` file extension at the root of the + tree, and it must match the cabal file blob key. The cabal file must + be located at `pkgname.cabal`. Each tree can be in at most one + package, and therefore tree keys work as package keys too. + +Note that with the above, a tree key is all the information necessary +to uniquely identify a package. However, including additional +information (package name, version, cabal key) in config files may be +useful for optimizations or user friendliness. If such extra +information is ever included, it must be validated to concur with the +package contents itself. + +### Package location + +Packages will optionally be sourced from some location: + +* __Hackage__ requires the package name, version number, and revision + number. Each revision of a package will end up with a different tree + key. +* __Archive__ takes a URL pointing to a tarball (gzipped or not) or a + ZIP file. An implicit assumption is that archives remain immutable + over time. Use tree keys to verify this assumption. (Same applies to + Hackage for that matter.) +* __Repository__ takes a repo type (Git or Mercurial), URL, and + commit. Assuming the veracity of the cryptographic hashes on the + repos, this should guarantee a unique set of files. + +In order to deal with _megarepos_ (repos and archives containing more +than one package), there is also a subdirectory for the archive and +repository cases. An empty subdir `""` would be the case for a +standard repo/archive. + +In order to meet the rules of a package listed above, the following +logic is applied to all three types above: + +* Find all of the files in the raw location, and represent as `Map + FilePath TreeEntry` (or equivalent). +* Remove a wrapper directory. If _all_ filepaths in that `Map` are + contained within the same directory, strip it from all of the + paths. For example, if the paths are `foo/bar` and `foo/baz`, the + paths will be reduced to `bar` and `baz`. +* After this wrapper is removed, then subdirectory logic is applied, + essentially applying `stripPrefix` to the filepaths. If the subdir + is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` + and `yesod-bin/yesod-bin.cabal`, the only file remaining after + subdir stripping would be `yesod-bin.cabal`. Note that trailing + slashes must be handled appropriately, and that an empty subdir + string results in this step being a noop. + +The result of all of this is that, given one of the three package +locations above, we can receive a tree key which will provide an +installable package. That tree key will remain immutable. + +### How tooling refers to packages + +We'll get to the caching mechanism for Pantry below. However, the +recommended approach for tooling is to support some kind of composite +of the Pantry keys, parsed info, and raw package location. This allows +for more efficient lookups when available, with a fallback when +mirrors don't have the needed information. + +An example: + +```yaml +extra-deps: +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz +``` + +It is also recommended that tooling provide an easy way to generate +such complete information from, e.g., just the URL of the tarball, and +that upon reading information, hashes, package names, and version +numbers are all checked for correctness. + +## Pantry caching + +One simplistic option for Pantry would be that, every time a piece of +data is needed, Pantry downloads the necessary tarball/Git +repo/etc. However, this would in practice be highly wasteful, since +downloading Git repos and archives just to get a single cabal file +(for plan construction purposes) is overkill. Instead, here's the +basic idea for how caching works: + +* All data for Pantry can be stored in a SQL database. Local tools + like Stack will use an SQLite database. Servers will use PostgreSQL. +* We'll define a network protocol (initially just HTTP, maybe + extending to something more efficient if desired) for querying blobs + and trees. +* When a blob or tree is needed, it is first checked for in the local + SQLite cache. If it's not available there, a request to the Pantry + mirrors (configurable) will be made for the data. Since everything + is content addressable, it is safe to use untrusted mirrors. +* If the data is not available in a mirror, and a location is + provided, the location will be downloaded and cached locally. + +We may also allow these Pantry mirrors to provide some kind of query +interface to find out, e.g., the latest version of a package on +Hackage. That's still TBD. + +## Example: resolving a package location + +To work through a full example, the following three stanzas are intended to +have equivalent behavior: + +```yaml +- archive: https://example.com/foobar-1.2.3.4.tar.gz + +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz + +- pantry: deadbeef + +``` + +The question is: how does the first one (presumably what a user would want to +enter) be resolved into the second and third? Pantry would follow this set of +steps: + +* Download the tarball from the given URL +* Place each file in the tarball into its store as a blob, getting a blob key + for each. The tarball is now represented as `Map FilePath BlobKey` +* Perform the root directory stripping step, removing a shared path +* Since there's no subdirectory: no subdirectory stripping would be performed +* Serialize the `Map FilePath BlobKey` to a binary format and take its hash to + get a tree key +* Store the tree in the store referenced by its tree key. In our example: the + tree key is `deadbeef`. +* Ensure that the tree is a valid package by checking for a single cabal file + at the root. In our example, that's found in `foobar.cabal` with blob key + `12345678`. +* Parse the cabal file and ensure that it is a valid cabal file, and that its + package name is `foobar`. Grab the version number (1.2.3.4). +* We now know that tree key `deadbeef` is a valid package, and can refer to it + by tree key exclusively. However, including the other information allows us + to verify our assumptions, provide user-friendly readable data, and provide a + fallback if the package isn't in the Pantry cache. + +## More advanced content discovery + +There are three more advanced cases to consider: + +* Providing fall-back locations for content, such as out of concern for a + single URL being removed in the future +* Closed corporate setups, where access to the general internet may either be + impossible or undesirable +* Automatic discovery of missing content by hash + +The following extensions are possible to address these cases: + +* Instead of a single package location, provide a list of package locations + with fallback semantics. +* Corporate environments will be encouraged to run a local Pantry mirror, and + configure clients like Stack to speak to these mirrors instead of the default + ones (or in addition to). +* Provide some kind of federation protocol for Pantry where servers can + registry with each other and requests for content can be pinged to each + other. + +Providing override at the client level for Pantry mirror locations is a +__MUST__. Making it easy to run in a corporate environment is a __SHOULD__. +Providing the fallback package locations seems easy enough that we should +include it initially, but falls under a __SHOULD__. The federated protocol +should be added on-demand. diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -1,19 +1,19 @@ -cabal-version: 1.12 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: pantry -version: 0.5.6 +version: 0.5.7 synopsis: Content addressable Haskell package management -description: Please see the README on Github at +description: Please see the README on GitHub at category: Development homepage: https://github.com/commercialhaskell/pantry#readme bug-reports: https://github.com/commercialhaskell/pantry/issues author: Michael Snoyman maintainer: michael@snoyman.com -copyright: 2018-2019 FP Complete +copyright: 2018-2022 FP Complete license: BSD3 license-file: LICENSE build-type: Simple @@ -53,7 +53,7 @@ src/ ghc-options: -Wall build-depends: - Cabal >=3 && <3.7 + Cabal >=3 && <3.9 , aeson , ansi-terminal , base >=4.10 && <5 @@ -99,6 +99,7 @@ , vector , yaml , zip-archive + default-language: Haskell2010 if os(windows) other-modules: System.IsWindows @@ -109,7 +110,6 @@ System.IsWindows hs-source-dirs: src/unix/ - default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 @@ -131,7 +131,7 @@ test ghc-options: -Wall build-depends: - Cabal >=3 && <3.7 + Cabal >=3 && <3.9 , QuickCheck , aeson , ansi-terminal 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 @@ -1,151 +1,151 @@ --- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - --- Adapted from `hackage-security-http-client` to use our own --- `Pantry.HTTP` implementation -module Hackage.Security.Client.Repository.HttpLib.HttpClient ( - httpLib - ) where - -import Control.Exception -import Control.Monad (void) -import Data.ByteString (ByteString) -import Network.URI -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS.C8 -import qualified Pantry.HTTP as HTTP - -import Hackage.Security.Client hiding (Header) -import Hackage.Security.Client.Repository.HttpLib -import Hackage.Security.Util.Checked - -{------------------------------------------------------------------------------- - Top-level API --------------------------------------------------------------------------------} - --- | An 'HttpLib' value using the default global manager -httpLib :: HttpLib -httpLib = HttpLib - { httpGet = get - , httpGetRange = getRange - } - -{------------------------------------------------------------------------------- - Individual methods --------------------------------------------------------------------------------} - -get :: Throws SomeRemoteError - => [HttpRequestHeader] -> URI - -> ([HttpResponseHeader] -> BodyReader -> IO a) - -> IO a -get reqHeaders uri callback = wrapCustomEx $ do - -- TODO: setUri fails under certain circumstances; in particular, when - -- the URI contains URL auth. Not sure if this is a concern. - request' <- HTTP.setUri HTTP.defaultRequest uri - let request = setRequestHeaders reqHeaders request' - checkHttpException $ HTTP.withResponse request $ \response -> do - let br = wrapCustomEx $ HTTP.getResponseBody response - callback (getResponseHeaders response) br - -getRange :: Throws SomeRemoteError - => [HttpRequestHeader] -> URI -> (Int, Int) - -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) - -> IO a -getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do - request' <- HTTP.setUri HTTP.defaultRequest uri - let request = setRange from to - $ setRequestHeaders reqHeaders request' - checkHttpException $ HTTP.withResponse request $ \response -> do - let br = wrapCustomEx $ HTTP.getResponseBody response - case () of - () | HTTP.getResponseStatus response == HTTP.partialContent206 -> - callback HttpStatus206PartialContent (getResponseHeaders response) br - () | HTTP.getResponseStatus response == HTTP.ok200 -> - callback HttpStatus200OK (getResponseHeaders response) br - _otherwise -> - throwChecked $ HTTP.HttpExceptionRequest request - $ HTTP.StatusCodeException (void response) "" - --- | Wrap custom exceptions --- --- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ --- but it is currently disabled -wrapCustomEx :: (Throws HTTP.HttpException => IO a) - -> (Throws SomeRemoteError => IO a) -wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act - where - go ex = throwChecked (SomeRemoteError ex) - -checkHttpException :: Throws HTTP.HttpException => IO a -> IO a -checkHttpException = handle $ \(ex :: HTTP.HttpException) -> - throwChecked ex - -{------------------------------------------------------------------------------- - http-client auxiliary --------------------------------------------------------------------------------} - -hAcceptRanges :: HTTP.HeaderName -hAcceptRanges = "Accept-Ranges" - -hAcceptEncoding :: HTTP.HeaderName -hAcceptEncoding = "Accept-Encoding" - -setRange :: Int -> Int - -> HTTP.Request -> HTTP.Request -setRange from to = - HTTP.addRequestHeader HTTP.hRange rangeHeader - where - -- Content-Range header uses inclusive rather than exclusive bounds - -- See - rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) - --- | Set request headers -setRequestHeaders :: [HttpRequestHeader] - -> HTTP.Request -> HTTP.Request -setRequestHeaders opts = - setRequestHeaders' (trOpt disallowCompressionByDefault opts) - where - setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request - setRequestHeaders' = foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id - - trOpt :: [(HTTP.HeaderName, [ByteString])] - -> [HttpRequestHeader] - -> [HTTP.Header] - trOpt acc [] = - map finalizeHeader acc - trOpt acc (HttpRequestMaxAge0:os) = - trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os - trOpt acc (HttpRequestNoTransform:os) = - trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os - - -- disable content compression (potential security issue) - disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] - disallowCompressionByDefault = [(hAcceptEncoding, [])] - - -- Some headers are comma-separated, others need multiple headers for - -- multiple options. - -- - -- TODO: Right we we just comma-separate all of them. - finalizeHeader :: (HTTP.HeaderName, [ByteString]) - -> HTTP.Header - finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) - - insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert _ _ [] = [] - insert x y ((k, v):pairs) - | x == k = (k, v ++ y) : insert x y pairs - | otherwise = (k, v) : insert x y pairs - --- | Extract the response headers -getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] -getResponseHeaders response = concat [ - [ HttpResponseAcceptRangesBytes - | (hAcceptRanges, "bytes") `elem` headers - ] - ] - where - headers = HTTP.getResponseHeaders response +-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Adapted from `hackage-security-http-client` to use our own +-- `Pantry.HTTP` implementation +module Hackage.Security.Client.Repository.HttpLib.HttpClient ( + httpLib + ) where + +import Control.Exception +import Control.Monad (void) +import Data.ByteString (ByteString) +import Network.URI +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.C8 +import qualified Pantry.HTTP as HTTP + +import Hackage.Security.Client hiding (Header) +import Hackage.Security.Client.Repository.HttpLib +import Hackage.Security.Util.Checked + +{------------------------------------------------------------------------------- + Top-level API +-------------------------------------------------------------------------------} + +-- | An 'HttpLib' value using the default global manager +httpLib :: HttpLib +httpLib = HttpLib + { httpGet = get + , httpGetRange = getRange + } + +{------------------------------------------------------------------------------- + Individual methods +-------------------------------------------------------------------------------} + +get :: Throws SomeRemoteError + => [HttpRequestHeader] -> URI + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +get reqHeaders uri callback = wrapCustomEx $ do + -- TODO: setUri fails under certain circumstances; in particular, when + -- the URI contains URL auth. Not sure if this is a concern. + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + callback (getResponseHeaders response) br + +getRange :: Throws SomeRemoteError + => [HttpRequestHeader] -> URI -> (Int, Int) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRange from to + $ setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + case () of + () | HTTP.getResponseStatus response == HTTP.partialContent206 -> + callback HttpStatus206PartialContent (getResponseHeaders response) br + () | HTTP.getResponseStatus response == HTTP.ok200 -> + callback HttpStatus200OK (getResponseHeaders response) br + _otherwise -> + throwChecked $ HTTP.HttpExceptionRequest request + $ HTTP.StatusCodeException (void response) "" + +-- | Wrap custom exceptions +-- +-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ +-- but it is currently disabled +wrapCustomEx :: (Throws HTTP.HttpException => IO a) + -> (Throws SomeRemoteError => IO a) +wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act + where + go ex = throwChecked (SomeRemoteError ex) + +checkHttpException :: Throws HTTP.HttpException => IO a -> IO a +checkHttpException = handle $ \(ex :: HTTP.HttpException) -> + throwChecked ex + +{------------------------------------------------------------------------------- + http-client auxiliary +-------------------------------------------------------------------------------} + +hAcceptRanges :: HTTP.HeaderName +hAcceptRanges = "Accept-Ranges" + +hAcceptEncoding :: HTTP.HeaderName +hAcceptEncoding = "Accept-Encoding" + +setRange :: Int -> Int + -> HTTP.Request -> HTTP.Request +setRange from to = + HTTP.addRequestHeader HTTP.hRange rangeHeader + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See + rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) + +-- | Set request headers +setRequestHeaders :: [HttpRequestHeader] + -> HTTP.Request -> HTTP.Request +setRequestHeaders opts = + setRequestHeaders' (trOpt disallowCompressionByDefault opts) + where + setRequestHeaders' :: [HTTP.Header] -> HTTP.Request -> HTTP.Request + setRequestHeaders' = foldr (\(name, val) f -> f . HTTP.setRequestHeader name [val]) id + + trOpt :: [(HTTP.HeaderName, [ByteString])] + -> [HttpRequestHeader] + -> [HTTP.Header] + trOpt acc [] = + map finalizeHeader acc + trOpt acc (HttpRequestMaxAge0:os) = + trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os + trOpt acc (HttpRequestNoTransform:os) = + trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os + + -- disable content compression (potential security issue) + disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] + disallowCompressionByDefault = [(hAcceptEncoding, [])] + + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we we just comma-separate all of them. + finalizeHeader :: (HTTP.HeaderName, [ByteString]) + -> HTTP.Header + finalizeHeader (name, strs) = (name, BS.intercalate ", " (reverse strs)) + + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert _ _ [] = [] + insert x y ((k, v):pairs) + | x == k = (k, v ++ y) : insert x y pairs + | otherwise = (k, v) : insert x y pairs + +-- | Extract the response headers +getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] +getResponseHeaders response = concat [ + [ HttpResponseAcceptRangesBytes + | (hAcceptRanges, "bytes") `elem` headers + ] + ] + where + headers = HTTP.getResponseHeaders response diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -1,1839 +1,1869 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Content addressable Haskell package management, providing for --- secure, reproducible acquisition of Haskell package contents and --- metadata. --- --- @since 0.1.0.0 -module Pantry - ( -- * Running - PantryConfig - , HackageSecurityConfig (..) - , defaultHackageSecurityConfig - , defaultCasaRepoPrefix - , defaultCasaMaxPerRequest - , defaultSnapshotLocation - , HasPantryConfig (..) - , withPantryConfig - , HpackExecutable (..) - - -- ** Convenience - , PantryApp - , runPantryApp - , runPantryAppClean - , runPantryAppWith - , hpackExecutableL - - -- * Types - - -- ** Exceptions - , PantryException (..) - - -- ** Cabal types - , PackageName - , Version - , FlagName - , PackageIdentifier (..) - - -- ** Files - , FileSize (..) - , RelFilePath (..) - , ResolvedPath (..) - , Unresolved - - -- ** Cryptography - , SHA256 - , TreeKey (..) - , BlobKey (..) - - -- ** Packages - , RawPackageMetadata (..) - , PackageMetadata (..) - , Package (..) - - -- ** Hackage - , CabalFileInfo (..) - , Revision (..) - , PackageIdentifierRevision (..) - , UsePreferredVersions (..) - - -- ** Archives - , RawArchive (..) - , Archive (..) - , ArchiveLocation (..) - - -- ** Repos - , Repo (..) - , RepoType (..) - , SimpleRepo (..) - , withRepo - , fetchRepos - , fetchReposRaw - - -- ** Package location - , RawPackageLocation (..) - , PackageLocation (..) - , toRawPL - , RawPackageLocationImmutable (..) - , PackageLocationImmutable (..) - - -- ** Snapshots - , RawSnapshotLocation (..) - , SnapshotLocation (..) - , toRawSL - , RawSnapshot (..) - , Snapshot (..) - , RawSnapshotPackage (..) - , SnapshotPackage (..) - , RawSnapshotLayer (..) - , SnapshotLayer (..) - , toRawSnapshotLayer - , WantedCompiler (..) - , SnapName (..) - , snapshotLocation - - -- * Loading values - , resolvePaths - , loadPackageRaw - , tryLoadPackageRawViaCasa - , loadPackage - , loadRawSnapshotLayer - , loadSnapshotLayer - , loadSnapshot - , loadAndCompleteSnapshot - , loadAndCompleteSnapshotRaw - , CompletedSL (..) - , CompletedPLI (..) - , addPackagesToSnapshot - , AddPackagesConfig (..) - - -- * Completion functions - , CompletePackageLocation (..) - , completePackageLocation - , completeSnapshotLocation - , warnMissingCabalFile - - -- * Parsers - , parseWantedCompiler - , parseSnapName - , parseRawSnapshotLocation - , parsePackageIdentifierRevision - , parseHackageText - - -- ** Cabal values - , parsePackageIdentifier - , parsePackageName - , parsePackageNameThrowing - , parseFlagName - , parseVersion - , parseVersionThrowing - - -- * Cabal helpers - , packageIdentifierString - , packageNameString - , flagNameString - , versionString - , moduleNameString - , CabalString (..) - , toCabalStringMap - , unCabalStringMap - , gpdPackageIdentifier - , gpdPackageName - , gpdVersion - - -- * Package location - , fetchPackages - , unpackPackageLocationRaw - , unpackPackageLocation - , getPackageLocationName - , getRawPackageLocationIdent - , packageLocationIdent - , packageLocationVersion - , getRawPackageLocationTreeKey - , getPackageLocationTreeKey - - -- * Cabal files - , loadCabalFileRaw - , loadCabalFile - , loadCabalFileRawImmutable - , loadCabalFileImmutable - , loadCabalFilePath - , findOrGenerateCabalFile - , PrintWarnings (..) - - -- * Hackage index - , updateHackageIndex - , DidUpdateOccur (..) - , RequireHackageIndex (..) - , hackageIndexTarballL - , getHackagePackageVersions - , getLatestHackageVersion - , getLatestHackageLocation - , getLatestHackageRevision - , getHackageTypoCorrections - , loadGlobalHints - , partitionReplacedDependencies - -- * Snapshot cache - , SnapshotCacheHash (..) - , withSnapshotCache - ) where - -import Database.Persist (entityKey) -import RIO -import Conduit -import Control.Arrow (right) -import Control.Monad.State.Strict (State, execState, get, modify') -import qualified RIO.Map as Map -import qualified RIO.Set as Set -import qualified RIO.ByteString as B -import qualified RIO.Text as T -import qualified RIO.List as List -import qualified RIO.FilePath as FilePath -import Pantry.Archive -import Pantry.Casa -import Casa.Client (thParserCasaRepo, CasaRepoPrefix) -import Pantry.Repo -import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage hiding (TreeEntry, PackageName, Version, findOrGenerateCabalFile) -import Pantry.Tree -import Pantry.Types as P -import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) -import Path.IO (doesFileExist, resolveDir', listDir) -import Distribution.PackageDescription (GenericPackageDescription, FlagName) -import qualified Distribution.PackageDescription as D -import Distribution.Parsec (PWarning (..), showPos) -import qualified Hpack -import qualified Hpack.Config as Hpack -import Network.HTTP.Download -import RIO.PrettyPrint -import RIO.PrettyPrint.StylesUpdate -import RIO.Process -import RIO.Directory (getAppUserDataDirectory) -import qualified Data.Yaml as Yaml -import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value) -import Data.Aeson.Types (parseEither) -import Data.Monoid (Endo (..)) -import Pantry.HTTP -import Data.Char (isHexDigit) -import Data.Time (getCurrentTime, diffUTCTime) - --- | Create a new 'PantryConfig' with the given settings. --- --- For something easier to use in simple cases, see 'runPantryApp'. --- --- @since 0.1.0.0 -withPantryConfig - :: HasLogFunc env - => Path Abs Dir - -- ^ pantry root directory, where the SQLite database and Hackage - -- downloads are kept. - -> HackageSecurityConfig - -- ^ Hackage configuration. You probably want - -- 'defaultHackageSecurityConfig'. - -> HpackExecutable - -- ^ When converting an hpack @package.yaml@ file to a cabal file, - -- what version of hpack should we use? - -> Int - -- ^ Maximum connection count - -> CasaRepoPrefix - -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull. - -> Int - -- ^ Max casa keys to pull per request. - -> (SnapName -> RawSnapshotLocation) - -- ^ The location of snapshot synonyms - -> (PantryConfig -> RIO env a) - -- ^ What to do with the config - -> RIO env a -withPantryConfig root hsc he count pullURL maxPerRequest snapLoc inner = do - env <- ask - pantryRelFile <- parseRelFile "pantry.sqlite3" - -- Silence persistent's logging output, which is really noisy - runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do - ur <- newMVar True - ref1 <- newIORef mempty - ref2 <- newIORef mempty - inner PantryConfig - { pcHackageSecurity = hsc - , pcHpackExecutable = he - , pcRootDir = root - , pcStorage = storage - , pcUpdateRef = ur - , pcConnectionCount = count - , pcParsedCabalFilesRawImmutable = ref1 - , pcParsedCabalFilesMutable = ref2 - , pcCasaRepoPrefix = pullURL - , pcCasaMaxPerRequest = maxPerRequest - , pcSnapshotLocation = snapLoc - } - --- | Default pull URL for Casa. --- --- @since 0.1.1.1 -defaultCasaRepoPrefix :: CasaRepoPrefix -defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com") - --- | Default max keys to pull per request. --- --- @since 0.1.1.1 -defaultCasaMaxPerRequest :: Int -defaultCasaMaxPerRequest = 1280 - --- | Default 'HackageSecurityConfig' value using the official Hackage server. --- --- @since 0.1.0.0 -defaultHackageSecurityConfig :: HackageSecurityConfig -defaultHackageSecurityConfig = HackageSecurityConfig - { hscKeyIds = - [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" - , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" - , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" - , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" - , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" - ] - , hscKeyThreshold = 3 - , hscDownloadPrefix = "https://hackage.haskell.org/" - , hscIgnoreExpiry = False - } - --- | Returns the latest version of the given package available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageVersion - :: (HasPantryConfig env, HasLogFunc env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> UsePreferredVersions - -> RIO env (Maybe PackageIdentifierRevision) -getLatestHackageVersion req name preferred = - ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name - where - go (version, m) = do - (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m - pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size - --- | Returns location of the latest version of the given package available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> UsePreferredVersions - -> RIO env (Maybe PackageLocationImmutable) -getLatestHackageLocation req name preferred = do - mversion <- - fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name - let mVerCfKey = do - (version, revisions) <- mversion - (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions - pure (version, cfKey) - - forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do - let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) - treeKey' <- getHackageTarballKey pir - pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' - --- | Returns the latest revision of the given package version available from --- Hackage. --- --- @since 0.1.0.0 -getLatestHackageRevision - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> Version - -> RIO env (Maybe (Revision, BlobKey, TreeKey)) -getLatestHackageRevision req name version = do - revisions <- getHackagePackageVersionRevisions req name version - case fmap fst $ Map.maxViewWithKey revisions of - Nothing -> pure Nothing - Just (revision, cfKey@(BlobKey sha size)) -> do - let cfi = CFIHash sha (Just size) - treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) - return $ Just (revision, cfKey, treeKey') - --- | Fetch keys and blobs and insert into the database where possible. -fetchTreeKeys :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [RawPackageLocationImmutable] - -> RIO env () -fetchTreeKeys treeKeys = do - pure () - -- Find all tree keys that are missing from the database. - packageLocationsMissing :: [RawPackageLocationImmutable] <- - withStorage - (filterM - (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) - treeKeys) - pullTreeStart <- liftIO getCurrentTime - -- Pull down those tree keys from Casa, automatically inserting into - -- our local database. - treeKeyBlobs :: Map TreeKey P.Tree <- - handleAny (const mempty) - (fmap - Map.fromList - (withStorage - (runConduitRes - (casaBlobSource - (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| - mapMC parseTreeM .| - sinkList)))) - pullTreeEnd <- liftIO getCurrentTime - let pulledPackages = - mapMaybe - (\treeKey' -> - List.find - ((== Just treeKey') . getRawTreeKey) - packageLocationsMissing) - (Map.keys treeKeyBlobs) - -- Pull down all unique file blobs. - let uniqueFileBlobKeys :: Set BlobKey - uniqueFileBlobKeys = - foldMap - (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) - treeKeyBlobs - pullBlobStart <- liftIO getCurrentTime - mpulledBlobKeys :: Maybe Int <- - handleAny (const (pure Nothing)) - (fmap Just (withStorage - (runConduitRes - (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)))) - for_ mpulledBlobKeys $ \pulledBlobKeys -> do - pullBlobEnd <- liftIO getCurrentTime - logDebug - ("Pulled from Casa: " <> - mconcat (List.intersperse ", " (map display pulledPackages)) <> - " (" <> - display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> - "), " <> - plural pulledBlobKeys "file" <> - " (" <> - display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> - ")") - -- Store the tree for each missing package. - for_ - packageLocationsMissing - (\rawPackageLocationImmutable -> - let mkey = getRawTreeKey rawPackageLocationImmutable - in case mkey of - Nothing -> - logDebug - ("Ignoring package with no tree key " <> - display rawPackageLocationImmutable <> - ", can't look in Casa for it.") - Just key -> - case Map.lookup key treeKeyBlobs of - Nothing -> - logDebug - ("Package key " <> display key <> " (" <> - display rawPackageLocationImmutable <> - ") not returned from Casa.") - Just tree -> do - identifier <- - getRawPackageLocationIdent rawPackageLocationImmutable - case findCabalOrHpackFile rawPackageLocationImmutable tree of - Just buildFile -> withStorage $ do - ecachedTree <- loadCachedTree tree - case ecachedTree of - Left e -> - lift $ logWarn - ("Loading cached tree after download from Casa failed on " <> - display rawPackageLocationImmutable <> ": " <> - displayShow e) - Right cachedTree -> - void $ storeTree - rawPackageLocationImmutable - identifier - cachedTree - buildFile - Nothing -> - logWarn - ("Unable to find build file for package: " <> - display rawPackageLocationImmutable)) - where - unTreeKey :: TreeKey -> BlobKey - unTreeKey (P.TreeKey blobKey) = blobKey - --- | Download all of the packages provided into the local cache --- without performing any unpacking. Can be useful for build tools --- wanting to prefetch or provide an offline mode. --- --- @since 0.1.0.0 -fetchPackages - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) - => f PackageLocationImmutable - -> RIO env () -fetchPackages pls = do - fetchTreeKeys (fmap toRawPLI (toList pls)) - traverseConcurrently_ (void . uncurry getHackageTarball) hackages - -- TODO in the future, be concurrent in these as well - fetchArchives archives - fetchRepos repos - where - s x = Endo (x:) - run (Endo f) = f [] - (hackagesE, archivesE, reposE) = foldMap go pls - hackages = run hackagesE - archives = run archivesE - repos = run reposE - - go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) - go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) - go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) - - toPir (PackageIdentifier name ver) (BlobKey sha size) = - PackageIdentifierRevision name ver (CFIHash sha (Just size)) - --- | Unpack a given 'RawPackageLocationImmutable' into the given --- directory. Does not generate any extra subdirectories. --- --- @since 0.1.0.0 -unpackPackageLocationRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ unpack directory - -> RawPackageLocationImmutable - -> RIO env () -unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree - --- | Unpack a given 'PackageLocationImmutable' into the given --- directory. Does not generate any extra subdirectories. --- --- @since 0.1.0.0 -unpackPackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ unpack directory - -> PackageLocationImmutable - -> RIO env () -unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree - --- | Load the cabal file for the given 'PackageLocationImmutable'. --- --- This function ignores all warnings. --- --- @since 0.1.0.0 -loadCabalFileImmutable - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env GenericPackageDescription -loadCabalFileImmutable loc = withCache $ do - logDebug $ "Parsing cabal file for " <> display loc - bs <- loadCabalFileBytes loc - (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs - let pm = - case loc of - PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata - { pmIdent = PackageIdentifier name version - , pmTreeKey = mtree - } - PLIArchive _ pm' -> pm' - PLIRepo _ pm' -> pm' - let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing - (gpdPackageIdentifier gpd) - PackageIdentifier name ver = pmIdent pm - maybe (throwIO exc) pure $ do - guard $ name == gpdPackageName gpd - guard $ ver == gpdVersion gpd - pure gpd - where - withCache inner = do - let rawLoc = toRawPLI loc - ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable - m0 <- readIORef ref - case Map.lookup rawLoc m0 of - Just x -> pure x - Nothing -> do - x <- inner - atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) - --- | Load the cabal file for the given 'RawPackageLocationImmutable'. --- --- This function ignores all warnings. --- --- Note that, for now, this will not allow support for hpack files in --- these package locations. Instead, all @PackageLocationImmutable@s --- will require a .cabal file. This may be relaxed in the future. --- --- @since 0.1.0.0 -loadCabalFileRawImmutable - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env GenericPackageDescription -loadCabalFileRawImmutable loc = withCache $ do - logDebug $ "Parsing cabal file for " <> display loc - bs <- loadRawCabalFileBytes loc - (_warnings, gpd) <- rawParseGPD (Left loc) bs - let rpm = - case loc of - RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just version - , rpmTreeKey = mtree - } - RPLIArchive _ rpm' -> rpm' - RPLIRepo _ rpm' -> rpm' - let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) - maybe (throwIO exc) pure $ do - guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) - guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) - pure gpd - where - withCache inner = do - ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable - m0 <- readIORef ref - case Map.lookup loc m0 of - Just x -> pure x - Nothing -> do - x <- inner - atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) - --- | Same as 'loadCabalFileRawImmutable', but takes a --- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath' --- for that. --- --- @since 0.1.0.0 -loadCabalFileRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocation - -> RIO env GenericPackageDescription -loadCabalFileRaw (RPLImmutable loc) = loadCabalFileRawImmutable loc -loadCabalFileRaw (RPLMutable rfp) = do - (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) - liftIO $ gpdio NoPrintWarnings - --- | Same as 'loadCabalFileImmutable', but takes a --- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath' --- for that. --- --- @since 0.1.0.0 -loadCabalFile - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocation - -> RIO env GenericPackageDescription -loadCabalFile (PLImmutable loc) = loadCabalFileImmutable loc -loadCabalFile (PLMutable rfp) = do - (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) - liftIO $ gpdio NoPrintWarnings - --- | Parse the cabal file for the package inside the given --- directory. Performs various sanity checks, such as the file name --- being correct and having only a single cabal file. --- --- @since 0.1.0.0 -loadCabalFilePath - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ project directory, with a cabal file or hpack file - -> RIO env - ( PrintWarnings -> IO GenericPackageDescription - , PackageName - , Path Abs File - ) -loadCabalFilePath dir = do - ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable - mcached <- Map.lookup dir <$> readIORef ref - case mcached of - Just triple -> pure triple - Nothing -> do - (name, cabalfp) <- findOrGenerateCabalFile dir - gpdRef <- newIORef Nothing - run <- askRunInIO - let gpdio = run . getGPD cabalfp gpdRef - triple = (gpdio, name, cabalfp) - atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) - where - getGPD cabalfp gpdRef printWarnings = do - mpair <- readIORef gpdRef - (warnings0, gpd) <- - case mpair of - Just pair -> pure pair - Nothing -> do - bs <- liftIO $ B.readFile $ toFilePath cabalfp - (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs - checkCabalFileName (gpdPackageName gpd) cabalfp - pure (warnings0, gpd) - warnings <- - case printWarnings of - YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] - NoPrintWarnings -> pure warnings0 - writeIORef gpdRef $ Just (warnings, gpd) - pure gpd - - toPretty :: Path Abs File -> PWarning -> Utf8Builder - toPretty src (PWarning _type pos msg) = - "Cabal file warning in" <> - fromString (toFilePath src) <> "@" <> - fromString (showPos pos) <> ": " <> - fromString msg - - -- | Check if the given name in the @Package@ matches the name of the .cabal file - checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () - checkCabalFileName name cabalfp = do - -- Previously, we just use parsePackageNameFromFilePath. However, that can - -- lead to confusing error messages. See: - -- https://github.com/commercialhaskell/stack/issues/895 - let expected = T.unpack $ unSafeFilePath $ cabalFileName name - when (expected /= toFilePath (filename cabalfp)) - $ throwM $ MismatchedCabalName cabalfp name - --- | Get the filename for the cabal file in the given directory. --- --- If no .cabal file is present, or more than one is present, an exception is --- thrown via 'throwM'. --- --- If the directory contains a file named package.yaml, hpack is used to --- generate a .cabal file from it. --- --- @since 0.1.0.0 -findOrGenerateCabalFile - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ package directory - -> RIO env (PackageName, Path Abs File) -findOrGenerateCabalFile pkgDir = do - hpack pkgDir - files <- filter (flip hasExtension "cabal" . toFilePath) . snd - <$> listDir pkgDir - -- If there are multiple files, ignore files that start with - -- ".". On unixlike environments these are hidden, and this - -- character is not valid in package names. The main goal is - -- to ignore emacs lock files - see - -- https://github.com/commercialhaskell/stack/issues/1897. - let isHidden ('.':_) = True - isHidden _ = False - case filter (not . isHidden . toFilePath . filename) files of - [] -> throwIO $ NoCabalFileFound pkgDir - [x] -> maybe - (throwIO $ InvalidCabalFilePath x) - (\pn -> pure $ (pn, x)) $ - List.stripSuffix ".cabal" (toFilePath (filename x)) >>= - parsePackageName - _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtension fp == "." ++ x - --- | Generate .cabal file from package.yaml, if necessary. -hpack - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir - -> RIO env () -hpack pkgDir = do - packageConfigRelFile <- parseRelFile Hpack.packageConfig - let hpackFile = pkgDir packageConfigRelFile - exists <- liftIO $ doesFileExist hpackFile - when exists $ do - logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) - - he <- view $ pantryConfigL.to pcHpackExecutable - case he of - HpackBundled -> do - r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions - forM_ (Hpack.resultWarnings r) (logWarn . fromString) - let cabalFile = fromString . Hpack.resultCabalFile $ r - case Hpack.resultStatus r of - Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile - Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile - Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ - cabalFile <> - " was generated with a newer version of hpack,\n" <> - "please upgrade and try again." - Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ - cabalFile <> - " was modified manually. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the cabal file.\nIf you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the cabal file,\n" <> - "then please delete the cabal file." - HpackCommand command -> - withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ - --- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier -gpdPackageIdentifier = D.package . D.packageDescription - --- | Get the 'PackageName' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdPackageName :: GenericPackageDescription -> PackageName -gpdPackageName = pkgName . gpdPackageIdentifier - --- | Get the 'Version' from a 'GenericPackageDescription'. --- --- @since 0.1.0.0 -gpdVersion :: GenericPackageDescription -> Version -gpdVersion = pkgVersion . gpdPackageIdentifier - -loadCabalFileBytes - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env ByteString - --- Just ignore the mtree for this. Safe assumption: someone who filled --- in the TreeKey also filled in the cabal file hash, and that's a --- more efficient lookup mechanism. -loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) - -loadCabalFileBytes pl = do - package <- loadPackage pl - let sfp = cabalFileName $ pkgName $ packageIdent package - cabalBlobKey <- case (packageCabalEntry package) of - PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack - PCCabalFile (TreeEntry blobKey _) -> pure blobKey - mbs <- withStorage $ loadBlob cabalBlobKey - case mbs of - Nothing -> do - throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey - Just bs -> pure bs - --- FIXME: to be removed -loadRawCabalFileBytes - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env ByteString - --- Just ignore the mtree for this. Safe assumption: someone who filled --- in the TreeKey also filled in the cabal file hash, and that's a --- more efficient lookup mechanism. -loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir - -loadRawCabalFileBytes pl = do - package <- loadPackageRaw pl - let sfp = cabalFileName $ pkgName $ packageIdent package - TreeEntry cabalBlobKey _ft = case packageCabalEntry package of - PCCabalFile cabalTE -> cabalTE - PCHpack hpackCE -> phGenerated hpackCE - mbs <- withStorage $ loadBlob cabalBlobKey - case mbs of - Nothing -> do - throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey - Just bs -> pure bs - --- | Load a 'Package' from a 'PackageLocationImmutable'. --- --- @since 0.1.0.0 -loadPackage - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env Package -loadPackage = loadPackageRaw . toRawPLI - --- | Load a 'Package' from a 'RawPackageLocationImmutable'. --- --- Load the package either from the local DB, Casa, or as a last --- resort, the third party (hackage, archive or repo). --- --- @since 0.1.0.0 -loadPackageRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env Package -loadPackageRaw rpli = do - case getRawTreeKey rpli of - Just treeKey' -> do - mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' - case mpackage of - Nothing -> loadPackageRawViaThirdParty - Just package -> pure package - Nothing -> loadPackageRawViaThirdParty - where - loadPackageRawViaThirdParty = do - logDebug ("Loading package from third-party: " <> display rpli) - case rpli of - RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree - RPLIArchive archive pm -> getArchivePackage rpli archive pm - RPLIRepo repo rpm -> getRepo repo rpm - --- | Try to load a package via the database or Casa. -tryLoadPackageRawViaDbOrCasa :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaDbOrCasa rpli treeKey' = do - mviaDb <- tryLoadPackageRawViaLocalDb rpli treeKey' - case mviaDb of - Just package -> do - logDebug ("Loaded package from Pantry: " <> display rpli) - pure (Just package) - Nothing -> do - mviaCasa <- tryLoadPackageRawViaCasa rpli treeKey' - case mviaCasa of - Just package -> do - logDebug ("Loaded package from Casa: " <> display rpli) - pure (Just package) - Nothing -> pure Nothing - --- | Maybe load the package from Casa. -tryLoadPackageRawViaCasa :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaCasa rlpi treeKey' = do - mtreePair <- casaLookupTree treeKey' - case mtreePair of - Nothing -> pure Nothing - Just (treeKey'', _tree) -> do - fetchTreeKeys [rlpi] - mdb <- tryLoadPackageRawViaLocalDb rlpi treeKey'' - case mdb of - Nothing -> do - logWarn - ("Did not find tree key in DB after pulling it from Casa: " <> - display treeKey'' <> - " (for " <> - display rlpi <> - ")") - pure Nothing - Just package -> pure (Just package) - --- | Maybe load the package from the local database. -tryLoadPackageRawViaLocalDb :: - (HasLogFunc env, HasPantryConfig env, HasProcessContext env) - => RawPackageLocationImmutable - -> TreeKey - -> RIO env (Maybe Package) -tryLoadPackageRawViaLocalDb rlpi treeKey' = do - mtreeEntity <- withStorage (getTreeForKey treeKey') - case mtreeEntity of - Nothing -> pure Nothing - Just treeId -> - fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) - --- | Complete package location, plus whether the package has a cabal file. This --- is relevant to reproducibility, see --- --- --- @since 0.4.0.0 -data CompletePackageLocation = CompletePackageLocation - { cplComplete :: !PackageLocationImmutable - , cplHasCabalFile :: !Bool - } - --- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. --- --- @since 0.1.0.0 -completePackageLocation - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env CompletePackageLocation -completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = - pure CompletePackageLocation - { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk - , cplHasCabalFile = True - } -completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do - logDebug $ "Completing package location information from " <> display pir0 - (pir, cfKey) <- - case cfi0 of - CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) - _ -> do - bs <- getHackageCabalFile pir0 - let size = FileSize (fromIntegral (B.length bs)) - sha = SHA256.hashBytes bs - cfi = CFIHash sha (Just size) - pir = PackageIdentifierRevision name version cfi - logDebug $ "Added in cabal file hash: " <> display pir - pure (pir, BlobKey sha size) - treeKey' <- getHackageTarballKey pir - pure CompletePackageLocation - { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' - , cplHasCabalFile = True - } -completePackageLocation pl@(RPLIArchive archive rpm) = do - mpackage <- - case rpmTreeKey rpm of - Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' - Nothing -> pure Nothing - case (,,) <$> raHash archive <*> raSize archive <*> mpackage of - Just (sha256, fileSize, package) -> do - let RawArchive loc _ _ subdir = archive - pure CompletePackageLocation - { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - Nothing -> byThirdParty (isJust mpackage) - where - byThirdParty warnAboutMissingSizeSha = do - (sha, size, package, _cachedTree) <- getArchive pl archive rpm - when warnAboutMissingSizeSha (warnWith sha size) - -- (getArchive checks archive and package metadata) - let RawArchive loc _ _ subdir = archive - logDebug $ fromString $ show (pl, sha, size, package) - pure CompletePackageLocation - { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - warnWith sha size = - logWarn - (mconcat - [ "The package " - , display pl - , " is available from the local content-addressable storage database, \n" - , "but we can't use it unless you specify the size and hash for this package.\n" - , "Add the following to your package description:\n" - , "\nsize: " <> display size - , "\nsha256: " <> display sha - ]) -completePackageLocation pl@(RPLIRepo repo rpm) = do - unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo - completePM repo pl rpm - where - isSHA1 t = T.length t == 40 && T.all isHexDigit t - -completePM - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Repo - -> RawPackageLocationImmutable - -> RawPackageMetadata - -> RIO env CompletePackageLocation -completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) - | Just n <- mn, Just v <- mv, Just tk <- mtk = do - let pm = PackageMetadata (PackageIdentifier n v) tk - pure CompletePackageLocation - { cplComplete = PLIRepo repo pm - -- This next bit is a hack: we don't know for certain that this is the case. - -- However, for the use case where complete package metadata has been supplied, - -- we'll assume there's a cabal file for purposes of generating a deprecation warning. - , cplHasCabalFile = True - } - | otherwise = do - package <- loadPackageRaw plOrig - let pm = packagePM package - let isSame x (Just y) = x == y - isSame _ _ = True - - allSame = - isSame (pkgName $ pmIdent pm) (rpmName rpm) && - isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && - isSame (pmTreeKey pm) (rpmTreeKey rpm) - if allSame - then pure CompletePackageLocation - { cplComplete = PLIRepo repo pm - , cplHasCabalFile = - case packageCabalEntry package of - PCCabalFile{} -> True - PCHpack{} -> False - } - else throwIO $ CompletePackageMetadataMismatch plOrig pm - -packagePM :: Package -> PackageMetadata -packagePM package = PackageMetadata - { pmIdent = packageIdent package - , pmTreeKey = packageTreeKey package - } - --- | Add in hashes to make a 'SnapshotLocation' reproducible. --- --- @since 0.1.0.0 -completeSnapshotLocation - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env SnapshotLocation -completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c -completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f -completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey -completeSnapshotLocation (RSLUrl url Nothing) = do - bs <- loadFromURL url Nothing - pure $ SLUrl url (bsToBlobKey bs) -completeSnapshotLocation (RSLSynonym syn) = - completeSnapshotLocation =<< snapshotLocation syn - -traverseConcurrently_ - :: (Foldable f, HasPantryConfig env) - => (a -> RIO env ()) -- ^ action to perform - -> f a -- ^ input values - -> RIO env () -traverseConcurrently_ f t0 = do - cnt <- view $ pantryConfigL.to pcConnectionCount - traverseConcurrentlyWith_ cnt f t0 - -traverseConcurrentlyWith_ - :: (MonadUnliftIO m, Foldable f) - => Int -- ^ concurrent workers - -> (a -> m ()) -- ^ action to perform - -> f a -- ^ input values - -> m () -traverseConcurrentlyWith_ count f t0 = do - queue <- newTVarIO $ toList t0 - - replicateConcurrently_ count $ - fix $ \loop -> join $ atomically $ do - toProcess <- readTVar queue - case toProcess of - [] -> pure (pure ()) - (x:rest) -> do - writeTVar queue rest - pure $ do - f x - loop - --- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. --- --- @since 0.1.0.0 -loadSnapshotRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> RIO env RawSnapshot -loadSnapshotRaw loc = do - eres <- loadRawSnapshotLayer loc - case eres of - Left wc -> - pure RawSnapshot - { rsCompiler = wc - , rsPackages = mempty - , rsDrop = mempty - } - Right (rsl, _) -> do - snap0 <- loadSnapshotRaw $ rslParent rsl - (packages, unused) <- - addPackagesToSnapshot - (display loc) - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (rsPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused - pure RawSnapshot - { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) - , rsPackages = packages - , rsDrop = apcDrop unused - } - --- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. --- --- @since 0.1.0.0 -loadSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => SnapshotLocation - -> RIO env RawSnapshot -loadSnapshot loc = do - eres <- loadSnapshotLayer loc - case eres of - Left wc -> - pure RawSnapshot - { rsCompiler = wc - , rsPackages = mempty - , rsDrop = mempty - } - Right rsl -> do - snap0 <- loadSnapshotRaw $ rslParent rsl - (packages, unused) <- - addPackagesToSnapshot - (display loc) - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (rsPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused - pure RawSnapshot - { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) - , rsPackages = packages - , rsDrop = apcDrop unused - } - --- | A completed package location, including the original raw and completed information. --- --- @since 0.1.0.0 -data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable - --- | A completed snapshot location, including the original raw and completed information. --- --- @since 0.1.0.0 -data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation - --- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting --- any incomplete package locations --- --- @since 0.1.0.0 -loadAndCompleteSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => SnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshot loc cachedSL cachedPL = - loadAndCompleteSnapshotRaw (toRawSL loc) cachedSL cachedPL - --- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing --- any incomplete package locations --- --- @since 0.1.0.0 -loadAndCompleteSnapshotRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file - -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) -loadAndCompleteSnapshotRaw rawLoc cacheSL cachePL = do - eres <- case Map.lookup rawLoc cacheSL of - Just loc -> right (\rsl -> (rsl, (CompletedSL rawLoc loc))) <$> loadSnapshotLayer loc - Nothing -> loadRawSnapshotLayer rawLoc - case eres of - Left wc -> - let snapshot = Snapshot - { snapshotCompiler = wc - , snapshotPackages = mempty - , snapshotDrop = mempty - } - in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) - Right (rsl, sloc) -> do - (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL - logDebug $ fromString $ show rsl - (packages, completed, unused) <- - addAndCompletePackagesToSnapshot - rawLoc - cachePL - (rslLocations rsl) - AddPackagesConfig - { apcDrop = rslDropPackages rsl - , apcFlags = rslFlags rsl - , apcHiddens = rslHidden rsl - , apcGhcOptions = rslGhcOptions rsl - } - (snapshotPackages snap0) - warnUnusedAddPackagesConfig (display rawLoc) unused - let snapshot = Snapshot - { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) - , snapshotPackages = packages - , snapshotDrop = apcDrop unused - } - return (snapshot, sloc : slocs,completed0 ++ completed) - -data SingleOrNot a - = Single !a - | Multiple !a !a !([a] -> [a]) -instance Semigroup (SingleOrNot a) where - Single a <> Single b = Multiple a b id - Single a <> Multiple b c d = Multiple a b ((c:) . d) - Multiple a b c <> Single d = Multiple a b (c . (d:)) - Multiple a b c <> Multiple d e f = - Multiple a b (c . (d:) . (e:) . f) - -sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) -sonToEither (k, Single a) = Left (k, a) -sonToEither (k, Multiple a b c) = Right (k, (a : b : c [])) - --- | Package settings to be passed to 'addPackagesToSnapshot'. --- --- @since 0.1.0.0 -data AddPackagesConfig = AddPackagesConfig - { apcDrop :: !(Set PackageName) - , apcFlags :: !(Map PackageName (Map FlagName Bool)) - , apcHiddens :: !(Map PackageName Bool) - , apcGhcOptions :: !(Map PackageName [Text]) - } - --- | Does not warn about drops, those are allowed in order to ignore global --- packages. -warnUnusedAddPackagesConfig - :: HasLogFunc env - => Utf8Builder -- ^ source - -> AddPackagesConfig - -> RIO env () -warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do - unless (null ls) $ do - logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" - traverse_ logWarn ls - where - ls = concat [flags', hiddens', options'] - - flags' = - map - (\pn -> - "Setting flags for non-existent package: " <> - fromString (packageNameString pn)) - (Map.keys flags) - - hiddens' = - map - (\pn -> - "Hiding non-existent package: " <> - fromString (packageNameString pn)) - (Map.keys hiddens) - - options' = - map - (\pn -> - "Setting options for non-existent package: " <> - fromString (packageNameString pn)) - (Map.keys options) - --- | Add more packages to a snapshot --- --- Note that any settings on a parent flag which is being replaced will be --- ignored. For example, if package @foo@ is in the parent and has flag @bar@ --- set, and @foo@ also appears in new packages, then @bar@ will no longer be --- set. --- --- Returns any of the 'AddPackagesConfig' values not used. --- --- @since 0.1.0.0 -addPackagesToSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Utf8Builder - -- ^ Text description of where these new packages are coming from, for error - -- messages only - -> [RawPackageLocationImmutable] -- ^ new packages - -> AddPackagesConfig - -> Map PackageName RawSnapshotPackage -- ^ packages from parent - -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) -addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do - new' <- for newPackages $ \loc -> do - name <- getPackageLocationName loc - pure (name, RawSnapshotPackage - { rspLocation = loc - , rspFlags = Map.findWithDefault mempty name flags - , rspHidden = Map.findWithDefault False name hiddens - , rspGhcOptions = Map.findWithDefault [] name options - }) - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) new' - unless (null $ newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> - rsp - { rspFlags = Map.findWithDefault (rspFlags rsp) name flags - , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens - , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options - } - - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) - - pure (allPackages, unused) - -cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Map RawPackageLocationImmutable PackageLocationImmutable - -> RawPackageLocationImmutable - -> RIO env (Maybe PackageLocationImmutable) -cachedSnapshotCompletePackageLocation cachePackages rpli = do - let xs = Map.lookup rpli cachePackages - case xs of - Nothing -> do - cpl <- completePackageLocation rpli - pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing - Just x -> pure $ Just x - --- | Add more packages to a snapshot completing their locations if needed --- --- Note that any settings on a parent flag which is being replaced will be --- ignored. For example, if package @foo@ is in the parent and has flag @bar@ --- set, and @foo@ also appears in new packages, then @bar@ will no longer be --- set. --- --- Returns any of the 'AddPackagesConfig' values not used and also all --- non-trivial package location completions. --- --- @since 0.1.0.0 -addAndCompletePackagesToSnapshot - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -- ^ Text description of where these new packages are coming from, for error - -- messages only - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> [RawPackageLocationImmutable] -- ^ new packages - -> AddPackagesConfig - -> Map PackageName SnapshotPackage -- ^ packages from parent - -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do - let source = display loc - addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ([(PackageName, SnapshotPackage)],[CompletedPLI]) - -> RawPackageLocationImmutable - -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) - addPackage (ps, completed) rawLoc = do - mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc - case mcomplLoc of - Nothing -> do - warnMissingCabalFile rawLoc - pure (ps, completed) - Just complLoc -> do - let PackageIdentifier name _ = packageLocationIdent complLoc - p = (name, SnapshotPackage - { spLocation = complLoc - , spFlags = Map.findWithDefault mempty name flags - , spHidden = Map.findWithDefault False name hiddens - , spGhcOptions = Map.findWithDefault [] name options - }) - completed' = if toRawPLI complLoc == rawLoc - then completed - else CompletedPLI rawLoc complLoc:completed - pure (p:ps, completed') - (revNew, revCompleted) <- foldM addPackage ([], []) newPackages - let (newSingles, newMultiples) - = partitionEithers - $ map sonToEither - $ Map.toList - $ Map.fromListWith (<>) - $ map (second Single) (reverse revNew) - unless (null $ newMultiples) $ throwIO $ - DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples - let new = Map.fromList newSingles - allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) - allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> - sp - { spFlags = Map.findWithDefault (spFlags sp) name flags - , spHidden = Map.findWithDefault (spHidden sp) name hiddens - , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options - } - - unused = AddPackagesConfig - (drops `Set.difference` Map.keysSet old) - (flags `Map.difference` allPackages) - (hiddens `Map.difference` allPackages) - (options `Map.difference` allPackages) - - pure (allPackages, reverse revCompleted, unused) - --- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. --- --- Returns a 'Left' value if provided an 'SLCompiler' --- constructor. Otherwise, returns a 'Right' value providing both the --- 'Snapshot' and a hash of the input configuration file. --- --- @since 0.1.0.0 -loadRawSnapshotLayer - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) -loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayer rsl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot rsl) $ do - bs <- loadFromURL url blob - value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelperRaw rsl value Nothing - pure $ Right (snapshot, (CompletedSL rsl (SLUrl url (bsToBlobKey bs)))) -loadRawSnapshotLayer rsl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot rsl) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) -loadRawSnapshotLayer rsl@(RSLSynonym syn) = do - loc <- snapshotLocation syn - comp <- loadRawSnapshotLayer loc - pure $ case comp of - Left wc -> Left wc - Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n) - --- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. --- --- Returns a 'Left' value if provided an 'SLCompiler' --- constructor. Otherwise, returns a 'Right' value providing both the --- 'Snapshot' and a hash of the input configuration file. --- --- @since 0.1.0.0 -loadSnapshotLayer - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotLocation - -> RIO env (Either WantedCompiler RawSnapshotLayer) -loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler -loadSnapshotLayer sl@(SLUrl url blob) = - handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do - bs <- loadFromURL url (Just blob) - value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelper sl value Nothing - pure $ Right snapshot -loadSnapshotLayer sl@(SLFilePath fp) = - handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right snapshot - -loadFromURL - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> Maybe BlobKey - -> RIO env ByteString -loadFromURL url Nothing = do - mcached <- withStorage $ loadURLBlob url - case mcached of - Just bs -> return bs - Nothing -> loadWithCheck url Nothing -loadFromURL url (Just bkey) = do - mcached <- withStorage $ loadBlob bkey - case mcached of - Just bs -> do - logDebug "Loaded snapshot from Pantry database." - return bs - Nothing -> loadUrlViaCasaOrWithCheck url bkey - -loadUrlViaCasaOrWithCheck - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> BlobKey - -> RIO env ByteString -loadUrlViaCasaOrWithCheck url blobKey = do - mblobFromCasa <- casaLookupKey blobKey - case mblobFromCasa of - Just blob -> do - logDebug - ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> - display url) - pure blob - Nothing -> loadWithCheck url (Just blobKey) - -loadWithCheck - :: (HasPantryConfig env, HasLogFunc env) - => Text -- ^ url - -> Maybe BlobKey - -> RIO env ByteString -loadWithCheck url mblobkey = do - let (msha, msize) = - case mblobkey of - Nothing -> (Nothing, Nothing) - Just (BlobKey sha size) -> (Just sha, Just size) - (_, _, bss) <- httpSinkChecked url msha msize sinkList - let bs = B.concat bss - withStorage $ storeURLBlob url bs - logDebug ("Loaded snapshot from third party: " <> display url) - return bs - -warningsParserHelperRaw - :: HasLogFunc env - => RawSnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayer -warningsParserHelperRaw rsl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot rsl e - Right (WithJSONWarnings x ws) -> do - unless (null ws) $ do - logWarn $ "Warnings when parsing snapshot " <> display rsl - for_ ws $ logWarn . display - resolvePaths mdir x - -warningsParserHelper - :: HasLogFunc env - => SnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayer -warningsParserHelper sl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e - Right (WithJSONWarnings x ws) -> do - unless (null ws) $ do - logWarn $ "Warnings when parsing snapshot " <> display sl - for_ ws $ logWarn . display - resolvePaths mdir x - --- | Get the 'PackageName' of the package at the given location. --- --- @since 0.1.0.0 -getPackageLocationName - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env PackageName -getPackageLocationName = fmap pkgName . getRawPackageLocationIdent - --- | Get the 'PackageIdentifier' of the package at the given location. --- --- @since 0.1.0.0 -packageLocationIdent - :: PackageLocationImmutable - -> PackageIdentifier -packageLocationIdent (PLIHackage ident _ _) = ident -packageLocationIdent (PLIRepo _ pm) = pmIdent pm -packageLocationIdent (PLIArchive _ pm) = pmIdent pm - --- | Get version of the package at the given location. --- --- @since 0.1.0.0 -packageLocationVersion - :: PackageLocationImmutable - -> Version -packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident -packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) -packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) - --- | Get the 'PackageIdentifier' of the package at the given location. --- --- @since 0.1.0.0 -getRawPackageLocationIdent - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env PackageIdentifier -getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version -getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version -getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli - --- | Get the 'TreeKey' of the package at the given location. --- --- @since 0.1.0.0 -getRawPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RIO env TreeKey -getRawPackageLocationTreeKey pl = - case getRawTreeKey pl of - Just treeKey' -> pure treeKey' - Nothing -> - case pl of - RPLIHackage pir _ -> getHackageTarballKey pir - RPLIArchive archive pm -> getArchiveKey pl archive pm - RPLIRepo repo pm -> getRepoKey repo pm - --- | Get the 'TreeKey' of the package at the given location. --- --- @since 0.1.0.0 -getPackageLocationTreeKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageLocationImmutable - -> RIO env TreeKey -getPackageLocationTreeKey pl = pure $ getTreeKey pl - -getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey -getRawTreeKey (RPLIHackage _ mtree) = mtree -getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm -getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm - -getTreeKey :: PackageLocationImmutable -> TreeKey -getTreeKey (PLIHackage _ _ tree) = tree -getTreeKey (PLIArchive _ pm) = pmTreeKey pm -getTreeKey (PLIRepo _ pm) = pmTreeKey pm - --- | Convenient data type that allows you to work with pantry more --- easily than using 'withPantryConfig' directly. Uses basically sane --- settings, like sharing a pantry directory with Stack. --- --- You can use 'runPantryApp' to use this. --- --- @since 0.1.0.0 -data PantryApp = PantryApp - { paSimpleApp :: !SimpleApp - , paPantryConfig :: !PantryConfig - , paUseColor :: !Bool - , paTermWidth :: !Int - , paStylesUpdate :: !StylesUpdate - } - -simpleAppL :: Lens' PantryApp SimpleApp -simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) - --- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' --- --- @since 0.1.0.0 -hpackExecutableL :: Lens' PantryConfig HpackExecutable -hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) - -instance HasLogFunc PantryApp where - logFuncL = simpleAppL.logFuncL -instance HasPantryConfig PantryApp where - pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) -instance HasProcessContext PantryApp where - processContextL = simpleAppL.processContextL -instance HasStylesUpdate PantryApp where - stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) -instance HasTerm PantryApp where - useColorL = lens paUseColor (\x y -> x { paUseColor = y }) - termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) - --- | Run some code against pantry using basic sane settings. --- --- For testing, see 'runPantryAppClean'. --- --- @since 0.1.0.0 -runPantryApp :: MonadIO m => RIO PantryApp a -> m a -runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest - --- | Run some code against pantry using basic sane settings. --- --- For testing, see 'runPantryAppClean'. --- --- @since 0.1.1.1 -runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a -runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do - sa <- ask - stack <- getAppUserDataDirectory "stack" - root <- parseAbsDir $ stack FilePath. "pantry" - withPantryConfig - root - defaultHackageSecurityConfig - HpackBundled - maxConnCount - casaRepoPrefix - casaMaxPerRequest - defaultSnapshotLocation - $ \pc -> - runRIO - PantryApp - { paSimpleApp = sa - , paPantryConfig = pc - , paTermWidth = 100 - , paUseColor = True - , paStylesUpdate = mempty - } - f - --- | Like 'runPantryApp', but uses an empty pantry directory instead --- of sharing with Stack. Useful for testing. --- --- @since 0.1.0.0 -runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a -runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do - sa <- ask - root <- resolveDir' dir - withPantryConfig - root - defaultHackageSecurityConfig - HpackBundled - 8 - defaultCasaRepoPrefix - defaultCasaMaxPerRequest - defaultSnapshotLocation - $ \pc -> - runRIO - PantryApp - { paSimpleApp = sa - , paPantryConfig = pc - , paTermWidth = 100 - , paUseColor = True - , paStylesUpdate = mempty - } - f - --- | Load the global hints from Github. --- --- @since 0.1.0.0 -loadGlobalHints - :: (HasTerm env, HasPantryConfig env) - => WantedCompiler - -> RIO env (Maybe (Map PackageName Version)) -loadGlobalHints wc = - inner False - where - inner alreadyDownloaded = do - dest <- getGlobalHintsFile - req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" - downloaded <- download req dest - eres <- tryAny (inner2 dest) - mres <- - case eres of - Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) - Right x -> pure x - case mres of - Nothing | not alreadyDownloaded && not downloaded -> do - logInfo $ - "Could not find local global hints for " <> - RIO.display wc <> - ", forcing a redownload" - x <- redownload req dest - if x - then inner True - else do - logInfo "Redownload didn't happen" - pure Nothing - _ -> pure mres - - inner2 dest - = liftIO - $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) - <$> Yaml.decodeFileThrow (toFilePath dest) - --- | Partition a map of global packages with its versions into a Set of --- replaced packages and its dependencies and a map of remaining (untouched) packages. --- --- @since 0.1.0.0 -partitionReplacedDependencies :: - Ord id - => Map PackageName a -- ^ global packages - -> (a -> PackageName) -- ^ package name getter - -> (a -> id) -- ^ returns unique package id used for dependency pruning - -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies - -> Set PackageName -- ^ overrides which global dependencies should get pruned - -> (Map PackageName [PackageName], Map PackageName a) -partitionReplacedDependencies globals getName getId getDeps overrides = - flip execState (replaced, mempty) $ - for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps - where - globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) - replaced = Map.map (const []) $ Map.restrictKeys globals overrides - -prunePackageWithDeps :: - Ord id - => Map id a - -> (a -> PackageName) - -> (a -> [id]) - -> (PackageName, a) - -> State (Map PackageName [PackageName], Map PackageName a) Bool -prunePackageWithDeps pkgs getName getDeps (pname, a) = do - (pruned, kept) <- get - if Map.member pname pruned - then return True - else if Map.member pname kept - then return False - else do - let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) - prunedDeps <- forMaybeM deps $ \dep -> do - let depName = getName dep - isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) - pure $ if isPruned then Just depName else Nothing - if null prunedDeps - then do - modify' $ second (Map.insert pname a) - else do - modify' $ first (Map.insert pname prunedDeps) - return $ not (null prunedDeps) - --- | Use a snapshot cache, which caches which modules are in which --- packages in a given snapshot. This is mostly intended for usage by --- Stack. --- --- @since 0.1.0.0 -withSnapshotCache - :: (HasPantryConfig env, HasLogFunc env) - => SnapshotCacheHash - -> RIO env (Map PackageName (Set ModuleName)) - -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) - -> RIO env a -withSnapshotCache hash getModuleMapping f = do - mres <- withStorage $ getSnapshotCacheByHash hash - cacheId <- case mres of - Nothing -> do - logWarn "Populating snapshot module name cache" - packageModules <- getModuleMapping - withStorage $ do - scId <- getSnapshotCacheId hash - storeSnapshotModuleCache scId packageModules - return scId - Just scId -> pure scId - f $ withStorage . loadExposedModulePackages cacheId - --- | Add an s to the builder if n!=1. -plural :: Int -> Utf8Builder -> Utf8Builder -plural n text = - display n <> " " <> text <> - (if n == 1 - then "" - else "s") +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Content addressable Haskell package management, providing for +-- secure, reproducible acquisition of Haskell package contents and +-- metadata. +-- +-- @since 0.1.0.0 +module Pantry + ( -- * Running + PantryConfig + , HackageSecurityConfig (..) + , defaultHackageSecurityConfig + , defaultCasaRepoPrefix + , defaultCasaMaxPerRequest + , defaultSnapshotLocation + , HasPantryConfig (..) + , withPantryConfig + , HpackExecutable (..) + + -- ** Convenience + , PantryApp + , runPantryApp + , runPantryAppClean + , runPantryAppWith + , hpackExecutableL + + -- * Types + + -- ** Exceptions + , PantryException (..) + + -- ** Cabal types + , PackageName + , Version + , FlagName + , PackageIdentifier (..) + + -- ** Files + , FileSize (..) + , RelFilePath (..) + , ResolvedPath (..) + , Unresolved + + -- ** Cryptography + , SHA256 + , TreeKey (..) + , BlobKey (..) + + -- ** Packages + , RawPackageMetadata (..) + , PackageMetadata (..) + , Package (..) + + -- ** Hackage + , CabalFileInfo (..) + , Revision (..) + , PackageIdentifierRevision (..) + , UsePreferredVersions (..) + + -- ** Archives + , RawArchive (..) + , Archive (..) + , ArchiveLocation (..) + + -- ** Repos + , Repo (..) + , RepoType (..) + , SimpleRepo (..) + , withRepo + , fetchRepos + , fetchReposRaw + + -- ** Package location + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + + -- ** Snapshots + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , WantedCompiler (..) + , SnapName (..) + , snapshotLocation + + -- * Loading values + , resolvePaths + , loadPackageRaw + , tryLoadPackageRawViaCasa + , loadPackage + , loadRawSnapshotLayer + , loadSnapshotLayer + , loadSnapshot + , loadAndCompleteSnapshot + , loadAndCompleteSnapshot' + , loadAndCompleteSnapshotRaw + , loadAndCompleteSnapshotRaw' + , CompletedSL (..) + , CompletedPLI (..) + , addPackagesToSnapshot + , AddPackagesConfig (..) + + -- * Completion functions + , CompletePackageLocation (..) + , completePackageLocation + , completeSnapshotLocation + , warnMissingCabalFile + + -- * Parsers + , parseWantedCompiler + , parseSnapName + , parseRawSnapshotLocation + , parsePackageIdentifierRevision + , parseHackageText + + -- ** Cabal values + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + + -- * Cabal helpers + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , gpdPackageIdentifier + , gpdPackageName + , gpdVersion + + -- * Package location + , fetchPackages + , unpackPackageLocationRaw + , unpackPackageLocation + , getPackageLocationName + , getRawPackageLocationIdent + , packageLocationIdent + , packageLocationVersion + , getRawPackageLocationTreeKey + , getPackageLocationTreeKey + + -- * Cabal files + , loadCabalFileRaw + , loadCabalFile + , loadCabalFileRawImmutable + , loadCabalFileImmutable + , loadCabalFilePath + , findOrGenerateCabalFile + , PrintWarnings (..) + + -- * Hackage index + , updateHackageIndex + , DidUpdateOccur (..) + , RequireHackageIndex (..) + , hackageIndexTarballL + , getHackagePackageVersions + , getLatestHackageVersion + , getLatestHackageLocation + , getLatestHackageRevision + , getHackageTypoCorrections + , loadGlobalHints + , partitionReplacedDependencies + -- * Snapshot cache + , SnapshotCacheHash (..) + , withSnapshotCache + ) where + +import Database.Persist (entityKey) +import RIO +import Conduit +import Control.Arrow (right) +import Control.Monad.State.Strict (State, execState, get, modify') +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import qualified RIO.ByteString as B +import qualified RIO.Text as T +import qualified RIO.List as List +import qualified RIO.FilePath as FilePath +import Pantry.Archive +import Pantry.Casa +import Casa.Client (thParserCasaRepo, CasaRepoPrefix) +import Pantry.Repo +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding (TreeEntry, PackageName, Version, findOrGenerateCabalFile) +import Pantry.Tree +import Pantry.Types as P +import Pantry.Hackage +import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) +import Path.IO (doesFileExist, resolveDir', listDir) +import Distribution.PackageDescription (GenericPackageDescription, FlagName) +import qualified Distribution.PackageDescription as D +import Distribution.Parsec (PWarning (..), showPos) +import qualified Hpack +import qualified Hpack.Config as Hpack +import Network.HTTP.Download +import RIO.PrettyPrint +import RIO.PrettyPrint.StylesUpdate +import RIO.Process +import RIO.Directory (getAppUserDataDirectory) +import qualified Data.Yaml as Yaml +import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value) +import Data.Aeson.Types (parseEither) +import Data.Monoid (Endo (..)) +import Pantry.HTTP +import Data.Char (isHexDigit) +import Data.Time (getCurrentTime, diffUTCTime) + +-- | Create a new 'PantryConfig' with the given settings. +-- +-- For something easier to use in simple cases, see 'runPantryApp'. +-- +-- @since 0.1.0.0 +withPantryConfig + :: HasLogFunc env + => Path Abs Dir + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. + -> HackageSecurityConfig + -- ^ Hackage configuration. You probably want + -- 'defaultHackageSecurityConfig'. + -> HpackExecutable + -- ^ When converting an hpack @package.yaml@ file to a cabal file, + -- what version of hpack should we use? + -> Int + -- ^ Maximum connection count + -> CasaRepoPrefix + -- ^ The casa pull URL e.g. https://casa.fpcomplete.com/v1/pull. + -> Int + -- ^ Max casa keys to pull per request. + -> (SnapName -> RawSnapshotLocation) + -- ^ The location of snapshot synonyms + -> (PantryConfig -> RIO env a) + -- ^ What to do with the config + -> RIO env a +withPantryConfig root hsc he count pullURL maxPerRequest snapLoc inner = do + env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" + -- Silence persistent's logging output, which is really noisy + runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do + ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty + inner PantryConfig + { pcHackageSecurity = hsc + , pcHpackExecutable = he + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + , pcConnectionCount = count + , pcParsedCabalFilesRawImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 + , pcCasaRepoPrefix = pullURL + , pcCasaMaxPerRequest = maxPerRequest + , pcSnapshotLocation = snapLoc + } + +-- | Default pull URL for Casa. +-- +-- @since 0.1.1.1 +defaultCasaRepoPrefix :: CasaRepoPrefix +defaultCasaRepoPrefix = $(thParserCasaRepo "https://casa.fpcomplete.com") + +-- | Default max keys to pull per request. +-- +-- @since 0.1.1.1 +defaultCasaMaxPerRequest :: Int +defaultCasaMaxPerRequest = 1280 + +-- | Default 'HackageSecurityConfig' value using the official Hackage server. +-- +-- @since 0.1.0.0 +defaultHackageSecurityConfig :: HackageSecurityConfig +defaultHackageSecurityConfig = HackageSecurityConfig + { hscKeyIds = + [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" + , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + ] + , hscKeyThreshold = 3 + , hscDownloadPrefix = "https://hackage.haskell.org/" + , hscIgnoreExpiry = False + } + +-- | Returns the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageVersion + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageIdentifierRevision) +getLatestHackageVersion req name preferred = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name + where + go (version, m) = do + (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m + pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size + +-- | Returns location of the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageLocationImmutable) +getLatestHackageLocation req name preferred = do + mversion <- + fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name + let mVerCfKey = do + (version, revisions) <- mversion + (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions + pure (version, cfKey) + + forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do + let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' + +-- | Returns the latest revision of the given package version available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageRevision + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> Version + -> RIO env (Maybe (Revision, BlobKey, TreeKey)) +getLatestHackageRevision req name version = do + revisions <- getHackagePackageVersionRevisions req name version + case fmap fst $ Map.maxViewWithKey revisions of + Nothing -> pure Nothing + Just (revision, cfKey@(BlobKey sha size)) -> do + let cfi = CFIHash sha (Just size) + treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + return $ Just (revision, cfKey, treeKey') + +-- | Fetch keys and blobs and insert into the database where possible. +fetchTreeKeys :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [RawPackageLocationImmutable] + -> RIO env () +fetchTreeKeys treeKeys = do + pure () + -- Find all tree keys that are missing from the database. + packageLocationsMissing :: [RawPackageLocationImmutable] <- + withStorage + (filterM + (fmap isNothing . maybe (pure Nothing) getTreeForKey . getRawTreeKey) + treeKeys) + pullTreeStart <- liftIO getCurrentTime + -- Pull down those tree keys from Casa, automatically inserting into + -- our local database. + treeKeyBlobs :: Map TreeKey P.Tree <- + handleAny (const mempty) + (fmap + Map.fromList + (withStorage + (runConduitRes + (casaBlobSource + (fmap unTreeKey (mapMaybe getRawTreeKey packageLocationsMissing)) .| + mapMC parseTreeM .| + sinkList)))) + pullTreeEnd <- liftIO getCurrentTime + let pulledPackages = + mapMaybe + (\treeKey' -> + List.find + ((== Just treeKey') . getRawTreeKey) + packageLocationsMissing) + (Map.keys treeKeyBlobs) + -- Pull down all unique file blobs. + let uniqueFileBlobKeys :: Set BlobKey + uniqueFileBlobKeys = + foldMap + (\(P.TreeMap files) -> Set.fromList (map teBlob (toList files))) + treeKeyBlobs + pullBlobStart <- liftIO getCurrentTime + mpulledBlobKeys :: Maybe Int <- + handleAny (const (pure Nothing)) + (fmap Just (withStorage + (runConduitRes + (casaBlobSource uniqueFileBlobKeys .| mapC (const 1) .| sumC)))) + for_ mpulledBlobKeys $ \pulledBlobKeys -> do + pullBlobEnd <- liftIO getCurrentTime + logDebug + ("Pulled from Casa: " <> + mconcat (List.intersperse ", " (map display pulledPackages)) <> + " (" <> + display (T.pack (show (diffUTCTime pullTreeEnd pullTreeStart))) <> + "), " <> + plural pulledBlobKeys "file" <> + " (" <> + display (T.pack (show (diffUTCTime pullBlobEnd pullBlobStart))) <> + ")") + -- Store the tree for each missing package. + for_ + packageLocationsMissing + (\rawPackageLocationImmutable -> + let mkey = getRawTreeKey rawPackageLocationImmutable + in case mkey of + Nothing -> + logDebug + ("Ignoring package with no tree key " <> + display rawPackageLocationImmutable <> + ", can't look in Casa for it.") + Just key -> + case Map.lookup key treeKeyBlobs of + Nothing -> + logDebug + ("Package key " <> display key <> " (" <> + display rawPackageLocationImmutable <> + ") not returned from Casa.") + Just tree -> do + identifier <- + getRawPackageLocationIdent rawPackageLocationImmutable + case findCabalOrHpackFile rawPackageLocationImmutable tree of + Just buildFile -> withStorage $ do + ecachedTree <- loadCachedTree tree + case ecachedTree of + Left e -> + lift $ logWarn + ("Loading cached tree after download from Casa failed on " <> + display rawPackageLocationImmutable <> ": " <> + displayShow e) + Right cachedTree -> + void $ storeTree + rawPackageLocationImmutable + identifier + cachedTree + buildFile + Nothing -> + logWarn + ("Unable to find build file for package: " <> + display rawPackageLocationImmutable)) + where + unTreeKey :: TreeKey -> BlobKey + unTreeKey (P.TreeKey blobKey) = blobKey + +-- | Download all of the packages provided into the local cache +-- without performing any unpacking. Can be useful for build tools +-- wanting to prefetch or provide an offline mode. +-- +-- @since 0.1.0.0 +fetchPackages + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) + => f PackageLocationImmutable + -> RIO env () +fetchPackages pls = do + fetchTreeKeys (fmap toRawPLI (toList pls)) + traverseConcurrently_ (void . uncurry getHackageTarball) hackages + -- TODO in the future, be concurrent in these as well + fetchArchives archives + fetchRepos repos + where + s x = Endo (x:) + run (Endo f) = f [] + (hackagesE, archivesE, reposE) = foldMap go pls + hackages = run hackagesE + archives = run archivesE + repos = run reposE + + go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) + go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) + go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) + + toPir (PackageIdentifier name ver) (BlobKey sha size) = + PackageIdentifierRevision name ver (CFIHash sha (Just size)) + +-- | Unpack a given 'RawPackageLocationImmutable' into the given +-- directory. Does not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocationRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> RawPackageLocationImmutable + -> RIO env () +unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree + +-- | Unpack a given 'PackageLocationImmutable' into the given +-- directory. Does not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> PackageLocationImmutable + -> RIO env () +unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree + +-- | Load the cabal file for the given 'PackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- @since 0.1.0.0 +loadCabalFileImmutable + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadCabalFileBytes loc + (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs + let pm = + case loc of + PLIHackage (PackageIdentifier name version) _cfHash mtree -> PackageMetadata + { pmIdent = PackageIdentifier name version + , pmTreeKey = mtree + } + PLIArchive _ pm' -> pm' + PLIRepo _ pm' -> pm' + let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing + (gpdPackageIdentifier gpd) + PackageIdentifier name ver = pmIdent pm + maybe (throwIO exc) pure $ do + guard $ name == gpdPackageName gpd + guard $ ver == gpdVersion gpd + pure gpd + where + withCache inner = do + let rawLoc = toRawPLI loc + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup rawLoc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) + +-- | Load the cabal file for the given 'RawPackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- Note that, for now, this will not allow support for hpack files in +-- these package locations. Instead, all @PackageLocationImmutable@s +-- will require a .cabal file. This may be relaxed in the future. +-- +-- @since 0.1.0.0 +loadCabalFileRawImmutable + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileRawImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadRawCabalFileBytes loc + (_warnings, gpd) <- rawParseGPD (Left loc) bs + let rpm = + case loc of + RPLIHackage (PackageIdentifierRevision name version _cfi) mtree -> RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version + , rpmTreeKey = mtree + } + RPLIArchive _ rpm' -> rpm' + RPLIRepo _ rpm' -> rpm' + let exc = MismatchedPackageMetadata loc rpm Nothing (gpdPackageIdentifier gpd) + maybe (throwIO exc) pure $ do + guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) + guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) + pure gpd + where + withCache inner = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup loc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) + +-- | Same as 'loadCabalFileRawImmutable', but takes a +-- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath' +-- for that. +-- +-- @since 0.1.0.0 +loadCabalFileRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocation + -> RIO env GenericPackageDescription +loadCabalFileRaw (RPLImmutable loc) = loadCabalFileRawImmutable loc +loadCabalFileRaw (RPLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Same as 'loadCabalFileImmutable', but takes a +-- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath' +-- for that. +-- +-- @since 0.1.0.0 +loadCabalFile + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocation + -> RIO env GenericPackageDescription +loadCabalFile (PLImmutable loc) = loadCabalFileImmutable loc +loadCabalFile (PLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Parse the cabal file for the package inside the given +-- directory. Performs various sanity checks, such as the file name +-- being correct and having only a single cabal file. +-- +-- @since 0.1.0.0 +loadCabalFilePath + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ project directory, with a cabal file or hpack file + -> RIO env + ( PrintWarnings -> IO GenericPackageDescription + , PackageName + , Path Abs File + ) +loadCabalFilePath dir = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable + mcached <- Map.lookup dir <$> readIORef ref + case mcached of + Just triple -> pure triple + Nothing -> do + (name, cabalfp) <- findOrGenerateCabalFile dir + gpdRef <- newIORef Nothing + run <- askRunInIO + let gpdio = run . getGPD cabalfp gpdRef + triple = (gpdio, name, cabalfp) + atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) + where + getGPD cabalfp gpdRef printWarnings = do + mpair <- readIORef gpdRef + (warnings0, gpd) <- + case mpair of + Just pair -> pure pair + Nothing -> do + bs <- liftIO $ B.readFile $ toFilePath cabalfp + (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs + checkCabalFileName (gpdPackageName gpd) cabalfp + pure (warnings0, gpd) + warnings <- + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] + NoPrintWarnings -> pure warnings0 + writeIORef gpdRef $ Just (warnings, gpd) + pure gpd + + toPretty :: Path Abs File -> PWarning -> Utf8Builder + toPretty src (PWarning _type pos msg) = + "Cabal file warning in" <> + fromString (toFilePath src) <> "@" <> + fromString (showPos pos) <> ": " <> + fromString msg + + -- | Check if the given name in the @Package@ matches the name of the .cabal file + checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () + checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = T.unpack $ unSafeFilePath $ cabalFileName name + when (expected /= toFilePath (filename cabalfp)) + $ throwM $ MismatchedCabalName cabalfp name + +-- | Get the filename for the cabal file in the given directory. +-- +-- If no .cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, hpack is used to +-- generate a .cabal file from it. +-- +-- @since 0.1.0.0 +findOrGenerateCabalFile + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (PackageName, Path Abs File) +findOrGenerateCabalFile pkgDir = do + hpack pkgDir + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . toFilePath . filename) files of + [] -> throwIO $ NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ InvalidCabalFilePath x) + (\pn -> pure $ (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + parsePackageName + _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Generate .cabal file from package.yaml, if necessary. +hpack + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir + -> RIO env () +hpack pkgDir = do + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir packageConfigRelFile + exists <- liftIO $ doesFileExist hpackFile + when exists $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile + Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile <> + " was generated with a newer version of hpack,\n" <> + "please upgrade and try again." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile <> + " was modified manually. Ignoring " <> + fromString (toFilePath hpackFile) <> + " in favor of the cabal file.\nIf you want to use the " <> + fromString (toFilePath (filename hpackFile)) <> + " file instead of the cabal file,\n" <> + "then please delete the cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ + +-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier +gpdPackageIdentifier = D.package . D.packageDescription + +-- | Get the 'PackageName' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = pkgName . gpdPackageIdentifier + +-- | Get the 'Version' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdVersion :: GenericPackageDescription -> Version +gpdVersion = pkgVersion . gpdPackageIdentifier + +loadCabalFileBytes + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) + +loadCabalFileBytes pl = do + package <- loadPackage pl + let sfp = cabalFileName $ pkgName $ packageIdent package + cabalBlobKey <- case (packageCabalEntry package) of + PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack + PCCabalFile (TreeEntry blobKey _) -> pure blobKey + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey + Just bs -> pure bs + +-- FIXME: to be removed +loadRawCabalFileBytes + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir + +loadRawCabalFileBytes pl = do + package <- loadPackageRaw pl + let sfp = cabalFileName $ pkgName $ packageIdent package + TreeEntry cabalBlobKey _ft = case packageCabalEntry package of + PCCabalFile cabalTE -> cabalTE + PCHpack hpackCE -> phGenerated hpackCE + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey + Just bs -> pure bs + +-- | Load a 'Package' from a 'PackageLocationImmutable'. +-- +-- @since 0.1.0.0 +loadPackage + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env Package +loadPackage = loadPackageRaw . toRawPLI + +-- | Load a 'Package' from a 'RawPackageLocationImmutable'. +-- +-- Load the package either from the local DB, Casa, or as a last +-- resort, the third party (hackage, archive or repo). +-- +-- @since 0.1.0.0 +loadPackageRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env Package +loadPackageRaw rpli = do + case getRawTreeKey rpli of + Just treeKey' -> do + mpackage <- tryLoadPackageRawViaDbOrCasa rpli treeKey' + case mpackage of + Nothing -> loadPackageRawViaThirdParty + Just package -> pure package + Nothing -> loadPackageRawViaThirdParty + where + loadPackageRawViaThirdParty = do + logDebug ("Loading package from third-party: " <> display rpli) + case rpli of + RPLIHackage pir mtree -> htrPackage <$> getHackageTarball pir mtree + RPLIArchive archive pm -> getArchivePackage rpli archive pm + RPLIRepo repo rpm -> getRepo repo rpm + +-- | Try to load a package via the database or Casa. +tryLoadPackageRawViaDbOrCasa :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaDbOrCasa rpli treeKey' = do + mviaDb <- tryLoadPackageRawViaLocalDb rpli treeKey' + case mviaDb of + Just package -> do + logDebug ("Loaded package from Pantry: " <> display rpli) + pure (Just package) + Nothing -> do + mviaCasa <- tryLoadPackageRawViaCasa rpli treeKey' + case mviaCasa of + Just package -> do + logDebug ("Loaded package from Casa: " <> display rpli) + pure (Just package) + Nothing -> pure Nothing + +-- | Maybe load the package from Casa. +tryLoadPackageRawViaCasa :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaCasa rlpi treeKey' = do + mtreePair <- casaLookupTree treeKey' + case mtreePair of + Nothing -> pure Nothing + Just (treeKey'', _tree) -> do + fetchTreeKeys [rlpi] + mdb <- tryLoadPackageRawViaLocalDb rlpi treeKey'' + case mdb of + Nothing -> do + logWarn + ("Did not find tree key in DB after pulling it from Casa: " <> + display treeKey'' <> + " (for " <> + display rlpi <> + ")") + pure Nothing + Just package -> pure (Just package) + +-- | Maybe load the package from the local database. +tryLoadPackageRawViaLocalDb :: + (HasLogFunc env, HasPantryConfig env, HasProcessContext env) + => RawPackageLocationImmutable + -> TreeKey + -> RIO env (Maybe Package) +tryLoadPackageRawViaLocalDb rlpi treeKey' = do + mtreeEntity <- withStorage (getTreeForKey treeKey') + case mtreeEntity of + Nothing -> pure Nothing + Just treeId -> + fmap Just (withStorage (loadPackageById rlpi (entityKey treeId))) + +-- | Complete package location, plus whether the package has a cabal file. This +-- is relevant to reproducibility, see +-- +-- +-- @since 0.4.0.0 +data CompletePackageLocation = CompletePackageLocation + { cplComplete :: !PackageLocationImmutable + , cplHasCabalFile :: !Bool + } + +-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. +-- +-- @since 0.1.0.0 +completePackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env CompletePackageLocation +completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk + , cplHasCabalFile = True + } +completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do + logDebug $ "Completing package location information from " <> display pir0 + (pir, cfKey) <- + case cfi0 of + CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) + _ -> do + bs <- getHackageCabalFile pir0 + let size = FileSize (fromIntegral (B.length bs)) + sha = SHA256.hashBytes bs + cfi = CFIHash sha (Just size) + pir = PackageIdentifierRevision name version cfi + logDebug $ "Added in cabal file hash: " <> display pir + pure (pir, BlobKey sha size) + treeKey' <- getHackageTarballKey pir + pure CompletePackageLocation + { cplComplete = PLIHackage (PackageIdentifier name version) cfKey treeKey' + , cplHasCabalFile = True + } +completePackageLocation pl@(RPLIArchive archive rpm) = do + mpackage <- + case rpmTreeKey rpm of + Just treeKey' -> tryLoadPackageRawViaDbOrCasa pl treeKey' + Nothing -> pure Nothing + case (,,) <$> raHash archive <*> raSize archive <*> mpackage of + Just (sha256, fileSize, package) -> do + let RawArchive loc _ _ subdir = archive + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha256 fileSize subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + Nothing -> byThirdParty (isJust mpackage) + where + byThirdParty warnAboutMissingSizeSha = do + (sha, size, package, _cachedTree) <- getArchive pl archive rpm + when warnAboutMissingSizeSha (warnWith sha size) + -- (getArchive checks archive and package metadata) + let RawArchive loc _ _ subdir = archive + logDebug $ fromString $ show (pl, sha, size, package) + pure CompletePackageLocation + { cplComplete = PLIArchive (Archive loc sha size subdir) (packagePM package) + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + warnWith sha size = + logWarn + (mconcat + [ "The package " + , display pl + , " is available from the local content-addressable storage database, \n" + , "but we can't use it unless you specify the size and hash for this package.\n" + , "Add the following to your package description:\n" + , "\nsize: " <> display size + , "\nsha256: " <> display sha + ]) +completePackageLocation pl@(RPLIRepo repo rpm) = do + unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo + completePM repo pl rpm + where + isSHA1 t = T.length t == 40 && T.all isHexDigit t + +completePM + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageLocationImmutable + -> RawPackageMetadata + -> RIO env CompletePackageLocation +completePM repo plOrig rpm@(RawPackageMetadata mn mv mtk) + | Just n <- mn, Just v <- mv, Just tk <- mtk = do + let pm = PackageMetadata (PackageIdentifier n v) tk + pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + -- This next bit is a hack: we don't know for certain that this is the case. + -- However, for the use case where complete package metadata has been supplied, + -- we'll assume there's a cabal file for purposes of generating a deprecation warning. + , cplHasCabalFile = True + } + | otherwise = do + package <- loadPackageRaw plOrig + let pm = packagePM package + let isSame x (Just y) = x == y + isSame _ _ = True + + allSame = + isSame (pkgName $ pmIdent pm) (rpmName rpm) && + isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && + isSame (pmTreeKey pm) (rpmTreeKey rpm) + if allSame + then pure CompletePackageLocation + { cplComplete = PLIRepo repo pm + , cplHasCabalFile = + case packageCabalEntry package of + PCCabalFile{} -> True + PCHpack{} -> False + } + else throwIO $ CompletePackageMetadataMismatch plOrig pm + +packagePM :: Package -> PackageMetadata +packagePM package = PackageMetadata + { pmIdent = packageIdent package + , pmTreeKey = packageTreeKey package + } + +-- | Add in hashes to make a 'SnapshotLocation' reproducible. +-- +-- @since 0.1.0.0 +completeSnapshotLocation + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env SnapshotLocation +completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c +completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f +completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey +completeSnapshotLocation (RSLUrl url Nothing) = do + bs <- loadFromURL url Nothing + pure $ SLUrl url (bsToBlobKey bs) +completeSnapshotLocation (RSLSynonym syn) = + completeSnapshotLocation =<< snapshotLocation syn + +traverseConcurrently_ + :: (Foldable f, HasPantryConfig env) + => (a -> RIO env ()) -- ^ action to perform + -> f a -- ^ input values + -> RIO env () +traverseConcurrently_ f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith_ cnt f t0 + +traverseConcurrentlyWith_ + :: (MonadUnliftIO m, Foldable f) + => Int -- ^ concurrent workers + -> (a -> m ()) -- ^ action to perform + -> f a -- ^ input values + -> m () +traverseConcurrentlyWith_ count f t0 = do + queue <- newTVarIO $ toList t0 + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + (x:rest) -> do + writeTVar queue rest + pure $ do + f x + loop + +-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshotRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> RIO env RawSnapshot +loadSnapshotRaw loc = do + eres <- loadRawSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right (rsl, _) -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> RIO env RawSnapshot +loadSnapshot loc = do + eres <- loadSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right rsl -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | A completed package location, including the original raw and completed information. +-- +-- @since 0.1.0.0 +data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable + +-- | A completed snapshot location, including the original raw and completed information. +-- +-- @since 0.1.0.0 +data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation + +-- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting +-- any incomplete package locations. Debug output will include the raw snapshot +-- layer. +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot = loadAndCompleteSnapshot' True + +-- | As for 'loadAndCompleteSnapshot' but allows toggling of the debug output of +-- the raw snapshot layer. +-- +-- @since 0.5.7 +loadAndCompleteSnapshot' + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Bool -- ^ Debug output includes the raw snapshot layer + -> SnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot' debugRSL loc cachedSL cachedPL = + loadAndCompleteSnapshotRaw' debugRSL (toRawSL loc) cachedSL cachedPL + +-- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing +-- any incomplete package locations. Debug output will include the raw snapshot +-- layer. +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshotRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw = loadAndCompleteSnapshotRaw' True + +-- As for 'loadAndCompleteSnapshotRaw' but allows toggling of the debug output +-- of the raw snapshot layer. +-- +-- @since 0.5.7 +loadAndCompleteSnapshotRaw' + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Bool -- ^ Debug output includes the raw snapshot layer + -> RawSnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw' debugRSL rawLoc cacheSL cachePL = do + eres <- case Map.lookup rawLoc cacheSL of + Just loc -> right (\rsl -> (rsl, (CompletedSL rawLoc loc))) <$> loadSnapshotLayer loc + Nothing -> loadRawSnapshotLayer rawLoc + case eres of + Left wc -> + let snapshot = Snapshot + { snapshotCompiler = wc + , snapshotPackages = mempty + , snapshotDrop = mempty + } + in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) + Right (rsl, sloc) -> do + (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw' debugRSL (rslParent rsl) cacheSL cachePL + when debugRSL $ logDebug $ fromString $ show rsl + (packages, completed, unused) <- + addAndCompletePackagesToSnapshot + rawLoc + cachePL + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (snapshotPackages snap0) + warnUnusedAddPackagesConfig (display rawLoc) unused + let snapshot = Snapshot + { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) + , snapshotPackages = packages + , snapshotDrop = apcDrop unused + } + return (snapshot, sloc : slocs,completed0 ++ completed) + +data SingleOrNot a + = Single !a + | Multiple !a !a !([a] -> [a]) +instance Semigroup (SingleOrNot a) where + Single a <> Single b = Multiple a b id + Single a <> Multiple b c d = Multiple a b ((c:) . d) + Multiple a b c <> Single d = Multiple a b (c . (d:)) + Multiple a b c <> Multiple d e f = + Multiple a b (c . (d:) . (e:) . f) + +sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) +sonToEither (k, Single a) = Left (k, a) +sonToEither (k, Multiple a b c) = Right (k, (a : b : c [])) + +-- | Package settings to be passed to 'addPackagesToSnapshot'. +-- +-- @since 0.1.0.0 +data AddPackagesConfig = AddPackagesConfig + { apcDrop :: !(Set PackageName) + , apcFlags :: !(Map PackageName (Map FlagName Bool)) + , apcHiddens :: !(Map PackageName Bool) + , apcGhcOptions :: !(Map PackageName [Text]) + } + +-- | Does not warn about drops, those are allowed in order to ignore global +-- packages. +warnUnusedAddPackagesConfig + :: HasLogFunc env + => Utf8Builder -- ^ source + -> AddPackagesConfig + -> RIO env () +warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do + unless (null ls) $ do + logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" + traverse_ logWarn ls + where + ls = concat [flags', hiddens', options'] + + flags' = + map + (\pn -> + "Setting flags for nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys flags) + + hiddens' = + map + (\pn -> + "Hiding nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys hiddens) + + options' = + map + (\pn -> + "Setting options for nonexistent package: " <> + fromString (packageNameString pn)) + (Map.keys options) + +-- | Add more packages to a snapshot +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used. +-- +-- @since 0.1.0.0 +addPackagesToSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Utf8Builder + -- ^ Text description of where these new packages are coming from, for error + -- messages only + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName RawSnapshotPackage -- ^ packages from parent + -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) +addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do + new' <- for newPackages $ \loc -> do + name <- getPackageLocationName loc + pure (name, RawSnapshotPackage + { rspLocation = loc + , rspFlags = Map.findWithDefault mempty name flags + , rspHidden = Map.findWithDefault False name hiddens + , rspGhcOptions = Map.findWithDefault [] name options + }) + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) new' + unless (null $ newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> + rsp + { rspFlags = Map.findWithDefault (rspFlags rsp) name flags + , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens + , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, unused) + +cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable + -> RawPackageLocationImmutable + -> RIO env (Maybe PackageLocationImmutable) +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages + case xs of + Nothing -> do + cpl <- completePackageLocation rpli + pure $ if cplHasCabalFile cpl then Just (cplComplete cpl) else Nothing + Just x -> pure $ Just x + +-- | Add more packages to a snapshot completing their locations if needed +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used and also all +-- non-trivial package location completions. +-- +-- @since 0.1.0.0 +addAndCompletePackagesToSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -- ^ Text description of where these new packages are coming from, for error + -- messages only + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName SnapshotPackage -- ^ packages from parent + -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) +addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do + let source = display loc + addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + mcomplLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc + case mcomplLoc of + Nothing -> do + warnMissingCabalFile rawLoc + pure (ps, completed) + Just complLoc -> do + let PackageIdentifier name _ = packageLocationIdent complLoc + p = (name, SnapshotPackage + { spLocation = complLoc + , spFlags = Map.findWithDefault mempty name flags + , spHidden = Map.findWithDefault False name hiddens + , spGhcOptions = Map.findWithDefault [] name options + }) + completed' = if toRawPLI complLoc == rawLoc + then completed + else CompletedPLI rawLoc complLoc:completed + pure (p:ps, completed') + (revNew, revCompleted) <- foldM addPackage ([], []) newPackages + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) (reverse revNew) + unless (null $ newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> + sp + { spFlags = Map.findWithDefault (spFlags sp) name flags + , spHidden = Map.findWithDefault (spHidden sp) name hiddens + , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, reverse revCompleted, unused) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' +-- constructor. Otherwise, returns a 'Right' value providing both the +-- 'Snapshot' and a hash of the input configuration file. +-- +-- @since 0.1.0.0 +loadRawSnapshotLayer + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) +loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler +loadRawSnapshotLayer rsl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + bs <- loadFromURL url blob + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelperRaw rsl value Nothing + pure $ Right (snapshot, (CompletedSL rsl (SLUrl url (bsToBlobKey bs)))) +loadRawSnapshotLayer rsl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) +loadRawSnapshotLayer rsl@(RSLSynonym syn) = do + loc <- snapshotLocation syn + comp <- loadRawSnapshotLayer loc + pure $ case comp of + Left wc -> Left wc + Right (l, CompletedSL _ n) -> Right (l, CompletedSL rsl n) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' +-- constructor. Otherwise, returns a 'Right' value providing both the +-- 'Snapshot' and a hash of the input configuration file. +-- +-- @since 0.1.0.0 +loadSnapshotLayer + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotLocation + -> RIO env (Either WantedCompiler RawSnapshotLayer) +loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler +loadSnapshotLayer sl@(SLUrl url blob) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + bs <- loadFromURL url (Just blob) + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelper sl value Nothing + pure $ Right snapshot +loadSnapshotLayer sl@(SLFilePath fp) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right snapshot + +loadFromURL + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadFromURL url Nothing = do + mcached <- withStorage $ loadURLBlob url + case mcached of + Just bs -> return bs + Nothing -> loadWithCheck url Nothing +loadFromURL url (Just bkey) = do + mcached <- withStorage $ loadBlob bkey + case mcached of + Just bs -> do + logDebug "Loaded snapshot from Pantry database." + return bs + Nothing -> loadUrlViaCasaOrWithCheck url bkey + +loadUrlViaCasaOrWithCheck + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> BlobKey + -> RIO env ByteString +loadUrlViaCasaOrWithCheck url blobKey = do + mblobFromCasa <- casaLookupKey blobKey + case mblobFromCasa of + Just blob -> do + logDebug + ("Loaded snapshot from Casa (" <> display blobKey <> ") for URL: " <> + display url) + pure blob + Nothing -> loadWithCheck url (Just blobKey) + +loadWithCheck + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadWithCheck url mblobkey = do + let (msha, msize) = + case mblobkey of + Nothing -> (Nothing, Nothing) + Just (BlobKey sha size) -> (Just sha, Just size) + (_, _, bss) <- httpSinkChecked url msha msize sinkList + let bs = B.concat bss + withStorage $ storeURLBlob url bs + logDebug ("Loaded snapshot from third party: " <> display url) + return bs + +warningsParserHelperRaw + :: HasLogFunc env + => RawSnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelperRaw rsl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot rsl e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display rsl + for_ ws $ logWarn . display + resolvePaths mdir x + +warningsParserHelper + :: HasLogFunc env + => SnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelper sl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display sl + for_ ws $ logWarn . display + resolvePaths mdir x + +-- | Get the 'PackageName' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationName + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageName +getPackageLocationName = fmap pkgName . getRawPackageLocationIdent + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationIdent + :: PackageLocationImmutable + -> PackageIdentifier +packageLocationIdent (PLIHackage ident _ _) = ident +packageLocationIdent (PLIRepo _ pm) = pmIdent pm +packageLocationIdent (PLIArchive _ pm) = pmIdent pm + +-- | Get version of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationVersion + :: PackageLocationImmutable + -> Version +packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident +packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) +packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationIdent + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageIdentifier +getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version +getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env TreeKey +getRawPackageLocationTreeKey pl = + case getRawTreeKey pl of + Just treeKey' -> pure treeKey' + Nothing -> + case pl of + RPLIHackage pir _ -> getHackageTarballKey pir + RPLIArchive archive pm -> getArchiveKey pl archive pm + RPLIRepo repo pm -> getRepoKey repo pm + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env TreeKey +getPackageLocationTreeKey pl = pure $ getTreeKey pl + +getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey +getRawTreeKey (RPLIHackage _ mtree) = mtree +getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm +getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm + +getTreeKey :: PackageLocationImmutable -> TreeKey +getTreeKey (PLIHackage _ _ tree) = tree +getTreeKey (PLIArchive _ pm) = pmTreeKey pm +getTreeKey (PLIRepo _ pm) = pmTreeKey pm + +-- | Convenient data type that allows you to work with pantry more +-- easily than using 'withPantryConfig' directly. Uses basically sane +-- settings, like sharing a pantry directory with Stack. +-- +-- You can use 'runPantryApp' to use this. +-- +-- @since 0.1.0.0 +data PantryApp = PantryApp + { paSimpleApp :: !SimpleApp + , paPantryConfig :: !PantryConfig + , paUseColor :: !Bool + , paTermWidth :: !Int + , paStylesUpdate :: !StylesUpdate + } + +simpleAppL :: Lens' PantryApp SimpleApp +simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) + +-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' +-- +-- @since 0.1.0.0 +hpackExecutableL :: Lens' PantryConfig HpackExecutable +hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) + +instance HasLogFunc PantryApp where + logFuncL = simpleAppL.logFuncL +instance HasPantryConfig PantryApp where + pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) +instance HasProcessContext PantryApp where + processContextL = simpleAppL.processContextL +instance HasStylesUpdate PantryApp where + stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) +instance HasTerm PantryApp where + useColorL = lens paUseColor (\x y -> x { paUseColor = y }) + termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) + +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.0.0 +runPantryApp :: MonadIO m => RIO PantryApp a -> m a +runPantryApp = runPantryAppWith 8 defaultCasaRepoPrefix defaultCasaMaxPerRequest + +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.1.1 +runPantryAppWith :: MonadIO m => Int -> CasaRepoPrefix -> Int -> RIO PantryApp a -> m a +runPantryAppWith maxConnCount casaRepoPrefix casaMaxPerRequest f = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack FilePath. "pantry" + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + maxConnCount + casaRepoPrefix + casaMaxPerRequest + defaultSnapshotLocation + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Like 'runPantryApp', but uses an empty pantry directory instead +-- of sharing with Stack. Useful for testing. +-- +-- @since 0.1.0.0 +runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a +runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do + sa <- ask + root <- resolveDir' dir + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + defaultCasaRepoPrefix + defaultCasaMaxPerRequest + defaultSnapshotLocation + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Load the global hints from GitHub. +-- +-- @since 0.1.0.0 +loadGlobalHints + :: (HasTerm env, HasPantryConfig env) + => WantedCompiler + -> RIO env (Maybe (Map PackageName Version)) +loadGlobalHints wc = + inner False + where + inner alreadyDownloaded = do + dest <- getGlobalHintsFile + req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" + downloaded <- download req dest + eres <- tryAny (inner2 dest) + mres <- + case eres of + Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) + Right x -> pure x + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + logInfo $ + "Could not find local global hints for " <> + RIO.display wc <> + ", forcing a redownload" + x <- redownload req dest + if x + then inner True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + + inner2 dest + = liftIO + $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) + <$> Yaml.decodeFileThrow (toFilePath dest) + +-- | Partition a map of global packages with its versions into a Set of +-- replaced packages and its dependencies and a map of remaining (untouched) packages. +-- +-- @since 0.1.0.0 +partitionReplacedDependencies :: + Ord id + => Map PackageName a -- ^ global packages + -> (a -> PackageName) -- ^ package name getter + -> (a -> id) -- ^ returns unique package id used for dependency pruning + -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies + -> Set PackageName -- ^ overrides which global dependencies should get pruned + -> (Map PackageName [PackageName], Map PackageName a) +partitionReplacedDependencies globals getName getId getDeps overrides = + flip execState (replaced, mempty) $ + for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps + where + globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) + replaced = Map.map (const []) $ Map.restrictKeys globals overrides + +prunePackageWithDeps :: + Ord id + => Map id a + -> (a -> PackageName) + -> (a -> [id]) + -> (PackageName, a) + -> State (Map PackageName [PackageName], Map PackageName a) Bool +prunePackageWithDeps pkgs getName getDeps (pname, a) = do + (pruned, kept) <- get + if Map.member pname pruned + then return True + else if Map.member pname kept + then return False + else do + let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) + prunedDeps <- forMaybeM deps $ \dep -> do + let depName = getName dep + isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) + pure $ if isPruned then Just depName else Nothing + if null prunedDeps + then do + modify' $ second (Map.insert pname a) + else do + modify' $ first (Map.insert pname prunedDeps) + return $ not (null prunedDeps) + +-- | Use a snapshot cache, which caches which modules are in which +-- packages in a given snapshot. This is mostly intended for usage by +-- Stack. +-- +-- @since 0.1.0.0 +withSnapshotCache + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotCacheHash + -> RIO env (Map PackageName (Set ModuleName)) + -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) + -> RIO env a +withSnapshotCache hash getModuleMapping f = do + mres <- withStorage $ getSnapshotCacheByHash hash + cacheId <- case mres of + Nothing -> do + logWarn "Populating snapshot module name cache" + packageModules <- getModuleMapping + withStorage $ do + scId <- getSnapshotCacheId hash + storeSnapshotModuleCache scId packageModules + return scId + Just scId -> pure scId + f $ withStorage . loadExposedModulePackages cacheId + +-- | Add an s to the builder if n!=1. +plural :: Int -> Utf8Builder -> Utf8Builder +plural n text = + display n <> " " <> text <> + (if n == 1 + then "" + else "s") diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs --- a/src/Pantry/Archive.hs +++ b/src/Pantry/Archive.hs @@ -1,535 +1,535 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Logic for loading up trees from HTTPS archives. -module Pantry.Archive - ( getArchivePackage - , getArchive - , getArchiveKey - , fetchArchivesRaw - , fetchArchives - , findCabalOrHpackFile - ) where - -import RIO -import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage hiding (Tree, TreeEntry) -import Pantry.Tree -import Pantry.Types -import RIO.Process -import Pantry.Internal (normalizeParents, makeTarRelative) -import qualified RIO.Text as T -import qualified RIO.Text.Partial as T -import qualified RIO.List as List -import qualified RIO.ByteString.Lazy as BL -import qualified RIO.Map as Map -import qualified RIO.Set as Set -import qualified Hpack.Config as Hpack -import Pantry.HPack (hpackVersion) -import Data.Bits ((.&.), shiftR) -import Path (toFilePath) -import qualified Codec.Archive.Zip as Zip -import qualified Data.Digest.CRC32 as CRC32 -import Distribution.PackageDescription (packageDescription, package) - -import Conduit -import Data.Conduit.Zlib (ungzip) -import qualified Data.Conduit.Tar as Tar -import Pantry.HTTP - -fetchArchivesRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(RawArchive, RawPackageMetadata)] - -> RIO env () -fetchArchivesRaw pairs = - for_ pairs $ \(ra, rpm) -> - getArchive (RPLIArchive ra rpm) ra rpm - -fetchArchives - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(Archive, PackageMetadata)] - -> RIO env () -fetchArchives pairs = - -- TODO be more efficient, group together shared archives - fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] - -getArchiveKey - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable -- ^ for exceptions - -> RawArchive - -> RawPackageMetadata - -> RIO env TreeKey -getArchiveKey rpli archive rpm = - packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization - -thd4 :: (a, b, c, d) -> c -thd4 (_, _, z, _) = z - -getArchivePackage - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) - => RawPackageLocationImmutable -- ^ for exceptions - -> RawArchive - -> RawPackageMetadata - -> RIO env Package -getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm - -getArchive - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) - => RawPackageLocationImmutable -- ^ for exceptions - -> RawArchive - -> RawPackageMetadata - -> RIO env (SHA256, FileSize, Package, CachedTree) -getArchive rpli archive rpm = do - -- Check if the value is in the cache, and use it if possible - mcached <- loadCache rpli archive - -- Ensure that all of the blobs referenced exist in the cache - -- See: https://github.com/commercialhaskell/pantry/issues/27 - mtree <- - case mcached of - Nothing -> pure Nothing - Just (_, _, pa) -> do - etree <- withStorage $ loadCachedTree $ packageTree pa - case etree of - Left e -> do - logDebug $ "getArchive of " <> displayShow rpli <> ": loadCachedTree failed: " <> displayShow e - pure Nothing - Right x -> pure $ Just x - cached@(_, _, pa, _) <- - case (mcached, mtree) of - (Just (a, b, c), Just d) -> pure (a, b, c, d) - -- Not in the archive. Load the archive. Completely ignore the - -- PackageMetadata for now, we'll check that the Package - -- info matches next. - _ -> withArchiveLoc archive $ \fp sha size -> do - (pa, tree) <- parseArchive rpli archive fp - -- Storing in the cache exclusively uses information we have - -- about the archive itself, not metadata from the user. - storeCache archive sha size pa - pure (sha, size, pa, tree) - - either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa - -storeCache - :: forall env. (HasPantryConfig env, HasLogFunc env) - => RawArchive - -> SHA256 - -> FileSize - -> Package - -> RIO env () -storeCache archive sha size pa = - case raLocation archive of - ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) - ALFilePath _ -> pure () -- TODO cache local as well - -loadCache - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RawArchive - -> RIO env (Maybe (SHA256, FileSize, Package)) -loadCache rpli archive = - case loc of - ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? - ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop - where - loc = raLocation archive - msha = raHash archive - msize = raSize archive - - loadFromCache :: TreeId -> RIO env (Maybe Package) - loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid - - loop [] = pure Nothing - loop ((sha, size, tid):rest) = - case msha of - Nothing -> do - case msize of - Just size' | size /= size' -> loop rest - _ -> do - case loc of - ALUrl url -> do - -- Only debug level, let lock files solve this - logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" - logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size - ALFilePath _ -> pure () - fmap (sha, size,) <$> loadFromCache tid - Just sha' - | sha == sha' -> - case msize of - Nothing -> do - case loc of - -- Only debug level, let lock files solve this - ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" - ALFilePath _ -> pure () - fmap (sha, size,) <$> loadFromCache tid - Just size' - | size == size' -> fmap (sha, size,) <$> loadFromCache tid - | otherwise -> do - -- This is an actual warning, since we have a concrete mismatch - logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" - logWarn "Please verify that your configuration provides the correct size" - loop rest - | otherwise -> loop rest - --- ensure name, version, etc are correct -checkPackageMetadata - :: RawPackageLocationImmutable - -> RawPackageMetadata - -> Package - -> Either PantryException Package -checkPackageMetadata pl pm pa = do - let - err = MismatchedPackageMetadata - pl - pm - (Just (packageTreeKey pa)) - (packageIdent pa) - - test :: Eq a => Maybe a -> a -> Bool - test (Just x) y = x == y - test Nothing _ = True - - tests = - [ test (rpmTreeKey pm) (packageTreeKey pa) - , test (rpmName pm) (pkgName $ packageIdent pa) - , test (rpmVersion pm) (pkgVersion $ packageIdent pa) - ] - - in if and tests then Right pa else Left err - --- | Provide a local file with the contents of the archive, regardless --- of where it comes from. Perform SHA256 and file size validation if --- downloading. -withArchiveLoc - :: HasLogFunc env - => RawArchive - -> (FilePath -> SHA256 -> FileSize -> RIO env a) - -> RIO env a -withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do - let abs' = resolvedAbsolute resolved - fp = toFilePath abs' - (sha, size) <- withBinaryFile fp ReadMode $ \h -> do - size <- FileSize . fromIntegral <$> hFileSize h - for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch - { mismatchExpected = size' - , mismatchActual = size - } - - sha <- runConduit (sourceHandle h .| SHA256.sinkHash) - for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch - { mismatchExpected = sha' - , mismatchActual = sha - } - - pure (sha, size) - f fp sha size -withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = - withSystemTempFile "archive" $ \fp hout -> do - logDebug $ "Downloading archive from " <> display url - (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) - hClose hout - f fp sha size - -data ArchiveType = ATTarGz | ATTar | ATZip - deriving (Enum, Bounded) - -instance Display ArchiveType where - display ATTarGz = "GZIP-ed tar file" - display ATTar = "Uncompressed tar file" - display ATZip = "Zip file" - -data METype - = METNormal - | METExecutable - | METLink !FilePath - deriving Show - -data MetaEntry = MetaEntry - { mePath :: !FilePath - , meType :: !METype - } - deriving Show - -foldArchive - :: (HasPantryConfig env, HasLogFunc env) - => ArchiveLocation -- ^ for error reporting - -> FilePath - -> ArchiveType - -> a - -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) - -> RIO env a -foldArchive loc fp ATTarGz accum f = - withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f -foldArchive loc fp ATTar accum f = - withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f -foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do - let go accum entry = do - let me = MetaEntry (Zip.eRelativePath entry) met - met = fromMaybe METNormal $ do - let modes = shiftR (Zip.eExternalFileAttributes entry) 16 - guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 - guard $ modes /= 0 - Just $ - if (modes .&. 0o100) == 0 - then METNormal - else METExecutable - lbs = Zip.fromEntry entry - let crcExpected = Zip.eCRC32 entry - crcActual = CRC32.crc32 lbs - when (crcExpected /= crcActual) - $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch - { mismatchExpected = crcExpected - , mismatchActual = crcActual - } - runConduit $ sourceLazy lbs .| f accum me - isDir entry = - case reverse $ Zip.eRelativePath entry of - '/':_ -> True - _ -> False - -- We're entering lazy I/O land thanks to zip-archive. - lbs <- BL.hGetContents h - foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) - -foldTar - :: (HasPantryConfig env, HasLogFunc env) - => ArchiveLocation -- ^ for exceptions - -> a - -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) - -> ConduitT ByteString o (RIO env) a -foldTar loc accum0 f = do - ref <- newIORef accum0 - Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do - accum <- readIORef ref - accum' <- f accum me - writeIORef ref $! accum') - readIORef ref - where - toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) - toME fi = do - let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) - mmet <- - case Tar.fileType fi of - Tar.FTSymbolicLink bs -> - case decodeUtf8' bs of - Left _ -> throwIO exc - Right text -> pure $ Just $ METLink $ T.unpack text - Tar.FTNormal -> pure $ Just $ - if Tar.fileMode fi .&. 0o100 /= 0 - then METExecutable - else METNormal - Tar.FTDirectory -> pure Nothing - _ -> throwIO exc - pure $ - (\met -> MetaEntry - { mePath = Tar.getFileInfoPath fi - , meType = met - }) - <$> mmet - -data SimpleEntry = SimpleEntry - { seSource :: !FilePath - , seType :: !FileType - } - deriving Show - - --- | Attempt to parse the contents of the given archive in the given --- subdir into a 'Tree'. This will not consult any caches. It will --- ensure that: --- --- * The cabal file exists --- --- * The cabal file can be parsed --- --- * The name inside the cabal file matches the name of the cabal file itself -parseArchive - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> RawArchive - -> FilePath -- ^ file holding the archive - -> RIO env (Package, CachedTree) -parseArchive rpli archive fp = do - let loc = raLocation archive - getFiles [] = throwIO $ UnknownArchiveType loc - getFiles (at:ats) = do - eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) - case eres of - Left e -> do - logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e - getFiles ats - Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) - (at :: ArchiveType, files :: Map FilePath MetaEntry) <- getFiles [minBound..maxBound] - let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) - toSimple key me = - case meType me of - METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal - METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable - METLink relDest -> do - case relDest of - '/':_ -> Left $ concat - [ "File located at " - , show $ mePath me - , " is a symbolic link to absolute path " - , relDest - ] - _ -> Right () - dest0 <- - case makeTarRelative (mePath me) relDest of - Left e -> Left $ concat - [ "Error resolving relative path " - , relDest - , " from symlink at " - , mePath me - , ": " - , e - ] - Right x -> Right x - dest <- - case normalizeParents dest0 of - Left e -> Left $ concat - [ "Invalid symbolic link from " - , mePath me - , " to " - , relDest - , ", tried parsing " - , dest0 - , ": " - , e - ] - Right x -> Right x - -- Check if it's a symlink to a file - case Map.lookup dest files of - Nothing -> - -- Check if it's a symlink to a directory - case findWithPrefix dest files of - [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" - ++ "This may indicate that the source is a git archive which uses git-annex.\n" - ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." - pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' - Just me' -> - case meType me' of - METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal - METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable - METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest - - case fold <$> Map.traverseWithKey toSimple files of - Left e -> throwIO $ UnsupportedTarball loc $ T.pack e - Right files1 -> do - let files2 = stripCommonPrefix $ Map.toList files1 - files3 = takeSubdir (raSubdir archive) files2 - toSafe (fp', a) = - case mkSafeFilePath fp' of - Nothing -> Left $ "Not a safe file path: " ++ show fp' - Just sfp -> Right (sfp, a) - case traverse toSafe files3 of - Left e -> throwIO $ UnsupportedTarball loc $ T.pack e - Right safeFiles -> do - let toSave = Set.fromList $ map (seSource . snd) safeFiles - (blobs :: Map FilePath (BlobKey, BlobId)) <- - foldArchive loc fp at mempty $ \m me -> - if mePath me `Set.member` toSave - then do - bs <- mconcat <$> sinkList - (blobId, blobKey) <- lift $ withStorage $ storeBlob bs - pure $ Map.insert (mePath me) (blobKey, blobId) m - else pure m - tree :: CachedTree <- fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> - case Map.lookup (seSource se) blobs of - Nothing -> error $ "Impossible: blob not found for: " ++ seSource se - Just (blobKey, blobId) -> pure (sfp, (TreeEntry blobKey (seType se), blobId)) - -- parse the cabal file and ensure it has the right name - buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree - (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of - BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) - BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) - mbs <- withStorage $ loadBlob buildFileBlobKey - bs <- - case mbs of - Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey - Just bs -> pure bs - cabalBs <- case buildFile of - BFCabal _ _ -> pure bs - BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) - (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs - let ident@(PackageIdentifier name _) = package $ packageDescription gpd - case buildFile of - BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name - _ -> return () - -- It's good! Store the tree, let's bounce - (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile - packageCabal <- case buildFile of - BFCabal _ _ -> pure $ PCCabalFile buildFileEntry - BFHpack _ -> do - cabalKey <- withStorage $ do - hpackId <- storeHPack rpli tid - loadCabalBlobKey hpackId - hpackSoftwareVersion <- hpackVersion - let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) - pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} - pure (Package - { packageTreeKey = treeKey' - , packageTree = unCachedTree tree - , packageCabalEntry = packageCabal - , packageIdent = ident - }, tree) - --- | Find all of the files in the Map with the given directory as a --- prefix. Directory is given without trailing slash. Returns the --- suffix after stripping the given prefix. -findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] -findWithPrefix dir = mapMaybe go . Map.toList - where - prefix = dir ++ "/" - go (x, y) = (, y) <$> List.stripPrefix prefix x - -findCabalOrHpackFile - :: MonadThrow m - => RawPackageLocationImmutable -- ^ for exceptions - -> Tree - -> m BuildFile -findCabalOrHpackFile loc (TreeMap m) = do - let isCabalFile (sfp, _) = - let txt = unSafeFilePath sfp - in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) - isHpackFile (sfp, _) = - let txt = unSafeFilePath sfp - in T.pack (Hpack.packageConfig) == txt - isBFCabal (BFCabal _ _) = True - isBFCabal _ = False - sfpBuildFile (BFCabal sfp _) = sfp - sfpBuildFile (BFHpack _) = hpackSafeFilePath - toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs) - then Just $ BFCabal sfp te - else Nothing - hpFile = if (isHpackFile xs) - then Just $ BFHpack te - else Nothing - in cbFile <|> hpFile - case mapMaybe toBuildFile $ Map.toList m of - [] -> throwM $ TreeWithoutCabalFile loc - [bfile] -> pure bfile - xs -> case (filter isBFCabal xs) of - [] -> throwM $ TreeWithoutCabalFile loc - [bfile] -> pure bfile - xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' - --- | If all files have a shared prefix, strip it off -stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] -stripCommonPrefix [] = [] -stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do - let firstDir = takeWhile (/= '/') firstFP - guard $ not $ null firstDir - let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp - stripCommonPrefix <$> traverse strip pairs - --- | Take us down to the specified subdirectory -takeSubdir - :: Text -- ^ subdir - -> [(FilePath, a)] -- ^ files after stripping common prefix - -> [(Text, a)] -takeSubdir subdir = mapMaybe $ \(fp, a) -> do - stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp - Just (T.intercalate "/" stripped, a) - where - splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" - subdirs = splitDirs subdir +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Logic for loading up trees from HTTPS archives. +module Pantry.Archive + ( getArchivePackage + , getArchive + , getArchiveKey + , fetchArchivesRaw + , fetchArchives + , findCabalOrHpackFile + ) where + +import RIO +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding (Tree, TreeEntry) +import Pantry.Tree +import Pantry.Types +import RIO.Process +import Pantry.Internal (normalizeParents, makeTarRelative) +import qualified RIO.Text as T +import qualified RIO.Text.Partial as T +import qualified RIO.List as List +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import qualified Hpack.Config as Hpack +import Pantry.HPack (hpackVersion) +import Data.Bits ((.&.), shiftR) +import Path (toFilePath) +import qualified Codec.Archive.Zip as Zip +import qualified Data.Digest.CRC32 as CRC32 +import Distribution.PackageDescription (packageDescription, package) + +import Conduit +import Data.Conduit.Zlib (ungzip) +import qualified Data.Conduit.Tar as Tar +import Pantry.HTTP + +fetchArchivesRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(RawArchive, RawPackageMetadata)] + -> RIO env () +fetchArchivesRaw pairs = + for_ pairs $ \(ra, rpm) -> + getArchive (RPLIArchive ra rpm) ra rpm + +fetchArchives + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Archive, PackageMetadata)] + -> RIO env () +fetchArchives pairs = + -- TODO be more efficient, group together shared archives + fetchArchivesRaw [(toRawArchive a, toRawPM pm) | (a, pm) <- pairs] + +getArchiveKey + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env TreeKey +getArchiveKey rpli archive rpm = + packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization + +thd4 :: (a, b, c, d) -> c +thd4 (_, _, z, _) = z + +getArchivePackage + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env Package +getArchivePackage rpli archive rpm = thd4 <$> getArchive rpli archive rpm + +getArchive + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env (SHA256, FileSize, Package, CachedTree) +getArchive rpli archive rpm = do + -- Check if the value is in the cache, and use it if possible + mcached <- loadCache rpli archive + -- Ensure that all of the blobs referenced exist in the cache + -- See: https://github.com/commercialhaskell/pantry/issues/27 + mtree <- + case mcached of + Nothing -> pure Nothing + Just (_, _, pa) -> do + etree <- withStorage $ loadCachedTree $ packageTree pa + case etree of + Left e -> do + logDebug $ "getArchive of " <> displayShow rpli <> ": loadCachedTree failed: " <> displayShow e + pure Nothing + Right x -> pure $ Just x + cached@(_, _, pa, _) <- + case (mcached, mtree) of + (Just (a, b, c), Just d) -> pure (a, b, c, d) + -- Not in the archive. Load the archive. Completely ignore the + -- PackageMetadata for now, we'll check that the Package + -- info matches next. + _ -> withArchiveLoc archive $ \fp sha size -> do + (pa, tree) <- parseArchive rpli archive fp + -- Storing in the cache exclusively uses information we have + -- about the archive itself, not metadata from the user. + storeCache archive sha size pa + pure (sha, size, pa, tree) + + either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa + +storeCache + :: forall env. (HasPantryConfig env, HasLogFunc env) + => RawArchive + -> SHA256 + -> FileSize + -> Package + -> RIO env () +storeCache archive sha size pa = + case raLocation archive of + ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) + ALFilePath _ -> pure () -- TODO cache local as well + +loadCache + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RawArchive + -> RIO env (Maybe (SHA256, FileSize, Package)) +loadCache rpli archive = + case loc of + ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? + ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop + where + loc = raLocation archive + msha = raHash archive + msize = raSize archive + + loadFromCache :: TreeId -> RIO env (Maybe Package) + loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid + + loop [] = pure Nothing + loop ((sha, size, tid):rest) = + case msha of + Nothing -> do + case msize of + Just size' | size /= size' -> loop rest + _ -> do + case loc of + ALUrl url -> do + -- Only debug level, let lock files solve this + logDebug $ "Using archive from " <> display url <> " without a specified cryptographic hash" + logDebug $ "Cached hash is " <> display sha <> ", file size " <> display size + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just sha' + | sha == sha' -> + case msize of + Nothing -> do + case loc of + -- Only debug level, let lock files solve this + ALUrl url -> logDebug $ "Archive from " <> display url <> " does not specify a size" + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just size' + | size == size' -> fmap (sha, size,) <$> loadFromCache tid + | otherwise -> do + -- This is an actual warning, since we have a concrete mismatch + logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" + logWarn "Please verify that your configuration provides the correct size" + loop rest + | otherwise -> loop rest + +-- ensure name, version, etc are correct +checkPackageMetadata + :: RawPackageLocationImmutable + -> RawPackageMetadata + -> Package + -> Either PantryException Package +checkPackageMetadata pl pm pa = do + let + err = MismatchedPackageMetadata + pl + pm + (Just (packageTreeKey pa)) + (packageIdent pa) + + test :: Eq a => Maybe a -> a -> Bool + test (Just x) y = x == y + test Nothing _ = True + + tests = + [ test (rpmTreeKey pm) (packageTreeKey pa) + , test (rpmName pm) (pkgName $ packageIdent pa) + , test (rpmVersion pm) (pkgVersion $ packageIdent pa) + ] + + in if and tests then Right pa else Left err + +-- | Provide a local file with the contents of the archive, regardless +-- of where it comes from. Perform SHA256 and file size validation if +-- downloading. +withArchiveLoc + :: HasLogFunc env + => RawArchive + -> (FilePath -> SHA256 -> FileSize -> RIO env a) + -> RIO env a +withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do + let abs' = resolvedAbsolute resolved + fp = toFilePath abs' + (sha, size) <- withBinaryFile fp ReadMode $ \h -> do + size <- FileSize . fromIntegral <$> hFileSize h + for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch + { mismatchExpected = size' + , mismatchActual = size + } + + sha <- runConduit (sourceHandle h .| SHA256.sinkHash) + for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch + { mismatchExpected = sha' + , mismatchActual = sha + } + + pure (sha, size) + f fp sha size +withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = + withSystemTempFile "archive" $ \fp hout -> do + logDebug $ "Downloading archive from " <> display url + (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) + hClose hout + f fp sha size + +data ArchiveType = ATTarGz | ATTar | ATZip + deriving (Enum, Bounded) + +instance Display ArchiveType where + display ATTarGz = "GZIP-ed tar file" + display ATTar = "Uncompressed tar file" + display ATZip = "Zip file" + +data METype + = METNormal + | METExecutable + | METLink !FilePath + deriving Show + +data MetaEntry = MetaEntry + { mePath :: !FilePath + , meType :: !METype + } + deriving Show + +foldArchive + :: (HasPantryConfig env, HasLogFunc env) + => ArchiveLocation -- ^ for error reporting + -> FilePath + -> ArchiveType + -> a + -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) + -> RIO env a +foldArchive loc fp ATTarGz accum f = + withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f +foldArchive loc fp ATTar accum f = + withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f +foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do + let go accum entry = do + let me = MetaEntry (Zip.eRelativePath entry) met + met = fromMaybe METNormal $ do + let modes = shiftR (Zip.eExternalFileAttributes entry) 16 + guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 + guard $ modes /= 0 + Just $ + if (modes .&. 0o100) == 0 + then METNormal + else METExecutable + lbs = Zip.fromEntry entry + let crcExpected = Zip.eCRC32 entry + crcActual = CRC32.crc32 lbs + when (crcExpected /= crcActual) + $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch + { mismatchExpected = crcExpected + , mismatchActual = crcActual + } + runConduit $ sourceLazy lbs .| f accum me + isDir entry = + case reverse $ Zip.eRelativePath entry of + '/':_ -> True + _ -> False + -- We're entering lazy I/O land thanks to zip-archive. + lbs <- BL.hGetContents h + foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) + +foldTar + :: (HasPantryConfig env, HasLogFunc env) + => ArchiveLocation -- ^ for exceptions + -> a + -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) + -> ConduitT ByteString o (RIO env) a +foldTar loc accum0 f = do + ref <- newIORef accum0 + Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do + accum <- readIORef ref + accum' <- f accum me + writeIORef ref $! accum') + readIORef ref + where + toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) + toME fi = do + let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) + mmet <- + case Tar.fileType fi of + Tar.FTSymbolicLink bs -> + case decodeUtf8' bs of + Left _ -> throwIO exc + Right text -> pure $ Just $ METLink $ T.unpack text + Tar.FTNormal -> pure $ Just $ + if Tar.fileMode fi .&. 0o100 /= 0 + then METExecutable + else METNormal + Tar.FTDirectory -> pure Nothing + _ -> throwIO exc + pure $ + (\met -> MetaEntry + { mePath = Tar.getFileInfoPath fi + , meType = met + }) + <$> mmet + +data SimpleEntry = SimpleEntry + { seSource :: !FilePath + , seType :: !FileType + } + deriving Show + + +-- | Attempt to parse the contents of the given archive in the given +-- subdir into a 'Tree'. This will not consult any caches. It will +-- ensure that: +-- +-- * The cabal file exists +-- +-- * The cabal file can be parsed +-- +-- * The name inside the cabal file matches the name of the cabal file itself +parseArchive + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RawArchive + -> FilePath -- ^ file holding the archive + -> RIO env (Package, CachedTree) +parseArchive rpli archive fp = do + let loc = raLocation archive + getFiles [] = throwIO $ UnknownArchiveType loc + getFiles (at:ats) = do + eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) + case eres of + Left e -> do + logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e + getFiles ats + Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) + (at :: ArchiveType, files :: Map FilePath MetaEntry) <- getFiles [minBound..maxBound] + let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) + toSimple key me = + case meType me of + METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable + METLink relDest -> do + case relDest of + '/':_ -> Left $ concat + [ "File located at " + , show $ mePath me + , " is a symbolic link to absolute path " + , relDest + ] + _ -> Right () + dest0 <- + case makeTarRelative (mePath me) relDest of + Left e -> Left $ concat + [ "Error resolving relative path " + , relDest + , " from symlink at " + , mePath me + , ": " + , e + ] + Right x -> Right x + dest <- + case normalizeParents dest0 of + Left e -> Left $ concat + [ "Invalid symbolic link from " + , mePath me + , " to " + , relDest + , ", tried parsing " + , dest0 + , ": " + , e + ] + Right x -> Right x + -- Check if it's a symlink to a file + case Map.lookup dest files of + Nothing -> + -- Check if it's a symlink to a directory + case findWithPrefix dest files of + [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" + ++ "This may indicate that the source is a git archive which uses git-annex.\n" + ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." + pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' + Just me' -> + case meType me' of + METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable + METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest + + case fold <$> Map.traverseWithKey toSimple files of + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e + Right files1 -> do + let files2 = stripCommonPrefix $ Map.toList files1 + files3 = takeSubdir (raSubdir archive) files2 + toSafe (fp', a) = + case mkSafeFilePath fp' of + Nothing -> Left $ "Not a safe file path: " ++ show fp' + Just sfp -> Right (sfp, a) + case traverse toSafe files3 of + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e + Right safeFiles -> do + let toSave = Set.fromList $ map (seSource . snd) safeFiles + (blobs :: Map FilePath (BlobKey, BlobId)) <- + foldArchive loc fp at mempty $ \m me -> + if mePath me `Set.member` toSave + then do + bs <- mconcat <$> sinkList + (blobId, blobKey) <- lift $ withStorage $ storeBlob bs + pure $ Map.insert (mePath me) (blobKey, blobId) m + else pure m + tree :: CachedTree <- fmap (CachedTreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> + case Map.lookup (seSource se) blobs of + Nothing -> error $ "Impossible: blob not found for: " ++ seSource se + Just (blobKey, blobId) -> pure (sfp, (TreeEntry blobKey (seType se), blobId)) + -- parse the cabal file and ensure it has the right name + buildFile <- findCabalOrHpackFile rpli $ unCachedTree tree + (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of + BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) + BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) + mbs <- withStorage $ loadBlob buildFileBlobKey + bs <- + case mbs of + Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey + Just bs -> pure bs + cabalBs <- case buildFile of + BFCabal _ _ -> pure bs + BFHpack _ -> snd <$> hpackToCabal rpli (unCachedTree tree) + (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs + let ident@(PackageIdentifier name _) = package $ packageDescription gpd + case buildFile of + BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name + _ -> return () + -- It's good! Store the tree, let's bounce + (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile + packageCabal <- case buildFile of + BFCabal _ _ -> pure $ PCCabalFile buildFileEntry + BFHpack _ -> do + cabalKey <- withStorage $ do + hpackId <- storeHPack rpli tid + loadCabalBlobKey hpackId + hpackSoftwareVersion <- hpackVersion + let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) + pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} + pure (Package + { packageTreeKey = treeKey' + , packageTree = unCachedTree tree + , packageCabalEntry = packageCabal + , packageIdent = ident + }, tree) + +-- | Find all of the files in the Map with the given directory as a +-- prefix. Directory is given without trailing slash. Returns the +-- suffix after stripping the given prefix. +findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] +findWithPrefix dir = mapMaybe go . Map.toList + where + prefix = dir ++ "/" + go (x, y) = (, y) <$> List.stripPrefix prefix x + +findCabalOrHpackFile + :: MonadThrow m + => RawPackageLocationImmutable -- ^ for exceptions + -> Tree + -> m BuildFile +findCabalOrHpackFile loc (TreeMap m) = do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) + isHpackFile (sfp, _) = + let txt = unSafeFilePath sfp + in T.pack (Hpack.packageConfig) == txt + isBFCabal (BFCabal _ _) = True + isBFCabal _ = False + sfpBuildFile (BFCabal sfp _) = sfp + sfpBuildFile (BFHpack _) = hpackSafeFilePath + toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs) + then Just $ BFCabal sfp te + else Nothing + hpFile = if (isHpackFile xs) + then Just $ BFHpack te + else Nothing + in cbFile <|> hpFile + case mapMaybe toBuildFile $ Map.toList m of + [] -> throwM $ TreeWithoutCabalFile loc + [bfile] -> pure bfile + xs -> case (filter isBFCabal xs) of + [] -> throwM $ TreeWithoutCabalFile loc + [bfile] -> pure bfile + xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' + +-- | If all files have a shared prefix, strip it off +stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] +stripCommonPrefix [] = [] +stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do + let firstDir = takeWhile (/= '/') firstFP + guard $ not $ null firstDir + let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp + stripCommonPrefix <$> traverse strip pairs + +-- | Take us down to the specified subdirectory +takeSubdir + :: Text -- ^ subdir + -> [(FilePath, a)] -- ^ files after stripping common prefix + -> [(Text, a)] +takeSubdir subdir = mapMaybe $ \(fp, a) -> do + stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp + Just (T.intercalate "/" stripped, a) + where + splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" + subdirs = splitDirs subdir diff --git a/src/Pantry/Casa.hs b/src/Pantry/Casa.hs --- a/src/Pantry/Casa.hs +++ b/src/Pantry/Casa.hs @@ -1,79 +1,79 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DisambiguateRecordFields #-} - --- | Integration with the Casa server. - -module Pantry.Casa where - -import qualified Casa.Client as Casa -import qualified Casa.Types as Casa -import Conduit -import qualified Data.HashMap.Strict as HM -import qualified Pantry.SHA256 as SHA256 -import Pantry.Storage -import Pantry.Types as P -import RIO -import qualified RIO.ByteString as B - --- | Lookup a tree. -casaLookupTree :: - (HasPantryConfig env, HasLogFunc env) - => TreeKey - -> RIO env (Maybe (TreeKey, P.Tree)) -casaLookupTree (P.TreeKey key) = - handleAny (const (pure Nothing)) - (withStorage - (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await))) - --- | Lookup a single blob. If possible, prefer 'casaBlobSource', and --- query a group of keys at once, rather than one at a time. This will --- have better network performance. -casaLookupKey :: - (HasPantryConfig env, HasLogFunc env) - => BlobKey - -> RIO env (Maybe ByteString) -casaLookupKey key = - handleAny (const (pure Nothing)) - (fmap - (fmap snd) - (withStorage (runConduitRes (casaBlobSource (Identity key) .| await)))) - --- | A source of blobs given a set of keys. All blobs are --- automatically stored in the local pantry database. -casaBlobSource :: - (Foldable f, HasPantryConfig env, HasLogFunc env) - => f BlobKey - -> ConduitT i (BlobKey, ByteString) (ResourceT (ReaderT SqlBackend (RIO env))) () -casaBlobSource keys = source .| convert .| store - where - source = do - pullUrl <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaRepoPrefix - maxPerRequest <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaMaxPerRequest - Casa.blobsSource - (Casa.SourceConfig - { sourceConfigUrl = pullUrl - , sourceConfigBlobs = toBlobKeyMap keys - , sourceConfigMaxBlobsPerRequest = maxPerRequest - }) - where - toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int - toBlobKeyMap = HM.fromList . map unpackBlobKey . toList - unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = - (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) - convert = mapMC toBlobKeyAndBlob - where - toBlobKeyAndBlob :: - MonadThrow m - => (Casa.BlobKey, ByteString) - -> m (BlobKey, ByteString) - toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do - sha256 <- - case SHA256.fromRaw keyBytes of - Left e -> throwM e - Right sha -> pure sha - pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) - store = mapMC insertBlob - where - insertBlob original@(_key, binary) = do - _ <- lift (storeBlob binary) - pure original +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DisambiguateRecordFields #-} + +-- | Integration with the Casa server. + +module Pantry.Casa where + +import qualified Casa.Client as Casa +import qualified Casa.Types as Casa +import Conduit +import qualified Data.HashMap.Strict as HM +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage +import Pantry.Types as P +import RIO +import qualified RIO.ByteString as B + +-- | Lookup a tree. +casaLookupTree :: + (HasPantryConfig env, HasLogFunc env) + => TreeKey + -> RIO env (Maybe (TreeKey, P.Tree)) +casaLookupTree (P.TreeKey key) = + handleAny (const (pure Nothing)) + (withStorage + (runConduitRes (casaBlobSource (Identity key) .| mapMC parseTreeM .| await))) + +-- | Lookup a single blob. If possible, prefer 'casaBlobSource', and +-- query a group of keys at once, rather than one at a time. This will +-- have better network performance. +casaLookupKey :: + (HasPantryConfig env, HasLogFunc env) + => BlobKey + -> RIO env (Maybe ByteString) +casaLookupKey key = + handleAny (const (pure Nothing)) + (fmap + (fmap snd) + (withStorage (runConduitRes (casaBlobSource (Identity key) .| await)))) + +-- | A source of blobs given a set of keys. All blobs are +-- automatically stored in the local pantry database. +casaBlobSource :: + (Foldable f, HasPantryConfig env, HasLogFunc env) + => f BlobKey + -> ConduitT i (BlobKey, ByteString) (ResourceT (ReaderT SqlBackend (RIO env))) () +casaBlobSource keys = source .| convert .| store + where + source = do + pullUrl <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaRepoPrefix + maxPerRequest <- lift $ lift $ lift $ view $ pantryConfigL . to pcCasaMaxPerRequest + Casa.blobsSource + (Casa.SourceConfig + { sourceConfigUrl = pullUrl + , sourceConfigBlobs = toBlobKeyMap keys + , sourceConfigMaxBlobsPerRequest = maxPerRequest + }) + where + toBlobKeyMap :: Foldable f => f BlobKey -> HashMap Casa.BlobKey Int + toBlobKeyMap = HM.fromList . map unpackBlobKey . toList + unpackBlobKey (P.BlobKey sha256 (FileSize fileSize)) = + (Casa.BlobKey (SHA256.toRaw sha256), fromIntegral fileSize) + convert = mapMC toBlobKeyAndBlob + where + toBlobKeyAndBlob :: + MonadThrow m + => (Casa.BlobKey, ByteString) + -> m (BlobKey, ByteString) + toBlobKeyAndBlob (Casa.BlobKey keyBytes, blob) = do + sha256 <- + case SHA256.fromRaw keyBytes of + Left e -> throwM e + Right sha -> pure sha + pure (BlobKey sha256 (FileSize (fromIntegral (B.length blob))), blob) + store = mapMC insertBlob + where + insertBlob original@(_key, binary) = do + _ <- lift (storeBlob binary) + pure original diff --git a/src/Pantry/HPack.hs b/src/Pantry/HPack.hs --- a/src/Pantry/HPack.hs +++ b/src/Pantry/HPack.hs @@ -1,72 +1,72 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} - -module Pantry.HPack - ( - hpack - , hpackVersion - ) where - -import RIO -import RIO.Process -import Pantry.Types -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Hpack -import qualified Hpack.Config as Hpack -import Data.Char (isSpace, isDigit) -import Path (Path, Abs, toFilePath, Dir, (), filename, parseRelFile) -import Path.IO (doesFileExist) - - -hpackVersion - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RIO env Version -hpackVersion = do - he <- view $ pantryConfigL.to pcHpackExecutable - case he of - HpackBundled -> do - let bundledHpackVersion :: String = VERSION_hpack - parseVersionThrowing bundledHpackVersion - HpackCommand command -> do - version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ - let version' = dropWhile (not . isDigit) version - version'' = filter (not . isSpace) version' - parseVersionThrowing version'' - --- | Generate .cabal file from package.yaml, if necessary. -hpack - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir - -> RIO env () -hpack pkgDir = do - packageConfigRelFile <- parseRelFile Hpack.packageConfig - let hpackFile = pkgDir Path. packageConfigRelFile - whenM (doesFileExist hpackFile) $ do - logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) - - he <- view $ pantryConfigL.to pcHpackExecutable - case he of - HpackBundled -> do - r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions - forM_ (Hpack.resultWarnings r) (logWarn . fromString) - let cabalFile = fromString . Hpack.resultCabalFile $ r - case Hpack.resultStatus r of - Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile - Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile - Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ - cabalFile <> - " was generated with a newer version of hpack,\n" <> - "please upgrade and try again." - Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ - cabalFile <> - " was modified manually. Ignoring " <> - fromString (toFilePath hpackFile) <> - " in favor of the cabal file.\nIf you want to use the " <> - fromString (toFilePath (filename hpackFile)) <> - " file instead of the cabal file,\n" <> - "then please delete the cabal file." - HpackCommand command -> - withWorkingDir (toFilePath pkgDir) $ - proc command [] runProcess_ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module Pantry.HPack + ( + hpack + , hpackVersion + ) where + +import RIO +import RIO.Process +import Pantry.Types +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Hpack +import qualified Hpack.Config as Hpack +import Data.Char (isSpace, isDigit) +import Path (Path, Abs, toFilePath, Dir, (), filename, parseRelFile) +import Path.IO (doesFileExist) + + +hpackVersion + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RIO env Version +hpackVersion = do + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + let bundledHpackVersion :: String = VERSION_hpack + parseVersionThrowing bundledHpackVersion + HpackCommand command -> do + version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ + let version' = dropWhile (not . isDigit) version + version'' = filter (not . isSpace) version' + parseVersionThrowing version'' + +-- | Generate .cabal file from package.yaml, if necessary. +hpack + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir + -> RIO env () +hpack pkgDir = do + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir Path. packageConfigRelFile + whenM (doesFileExist hpackFile) $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile + Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile <> + " was generated with a newer version of hpack,\n" <> + "please upgrade and try again." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile <> + " was modified manually. Ignoring " <> + fromString (toFilePath hpackFile) <> + " in favor of the cabal file.\nIf you want to use the " <> + fromString (toFilePath (filename hpackFile)) <> + " file instead of the cabal file,\n" <> + "then please delete the cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ diff --git a/src/Pantry/HTTP.hs b/src/Pantry/HTTP.hs --- a/src/Pantry/HTTP.hs +++ b/src/Pantry/HTTP.hs @@ -1,101 +1,101 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Pantry.HTTP - ( module Export - , withResponse - , httpSink - , httpSinkChecked - ) where - -import Conduit -import Network.HTTP.Client as Export (parseRequest) -import Network.HTTP.Client as Export (parseUrlThrow) -import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) -import qualified Network.HTTP.Client as HTTP (withResponse) -import Network.HTTP.Client.Internal as Export (setUri) -import Network.HTTP.Client.TLS (getGlobalManager) -import Network.HTTP.Simple as Export (HttpException (..), - Request, Response, - addRequestHeader, - defaultRequest, - getResponseBody, - getResponseHeaders, - getResponseStatus, - setRequestHeader) -import qualified Network.HTTP.Simple as HTTP hiding (withResponse) -import Network.HTTP.Types as Export (Header, HeaderName, - Status, hCacheControl, - hRange, ok200, - partialContent206, - statusCode) -import qualified Pantry.SHA256 as SHA256 -import Pantry.Types -import RIO -import qualified RIO.ByteString as B -import qualified RIO.Text as T - -setUserAgent :: Request -> Request -setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] - -withResponse - :: MonadUnliftIO m - => HTTP.Request - -> (Response BodyReader -> m a) - -> m a -withResponse req inner = withRunInIO $ \run -> do - manager <- getGlobalManager - HTTP.withResponse (setUserAgent req) manager (run . inner) - -httpSink - :: MonadUnliftIO m - => Request - -> (Response () -> ConduitT ByteString Void m a) - -> m a -httpSink req inner = HTTP.httpSink (setUserAgent req) inner - -httpSinkChecked - :: MonadUnliftIO m - => Text - -> Maybe SHA256 - -> Maybe FileSize - -> ConduitT ByteString Void m a - -> m (SHA256, FileSize, a) -httpSinkChecked url msha msize sink = do - req <- liftIO $ parseUrlThrow $ T.unpack url - httpSink req $ const $ getZipSink $ (,,) - <$> ZipSink (checkSha msha) - <*> ZipSink (checkSize msize) - <*> ZipSink sink - where - checkSha mexpected = do - actual <- SHA256.sinkHash - for_ mexpected $ \expected -> unless (actual == expected) $ - throwIO $ DownloadInvalidSHA256 url Mismatch - { mismatchExpected = expected - , mismatchActual = actual - } - pure actual - checkSize mexpected = - loop 0 - where - loop accum = do - mbs <- await - case mbs of - Nothing -> - case mexpected of - Just (FileSize expected) | expected /= accum -> - throwIO $ DownloadInvalidSize url Mismatch - { mismatchExpected = FileSize expected - , mismatchActual = FileSize accum - } - _ -> pure (FileSize accum) - Just bs -> do - let accum' = accum + fromIntegral (B.length bs) - case mexpected of - Just (FileSize expected) - | accum' > expected -> - throwIO $ DownloadTooLarge url Mismatch - { mismatchExpected = FileSize expected - , mismatchActual = FileSize accum' - } - _ -> loop accum' +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.HTTP + ( module Export + , withResponse + , httpSink + , httpSinkChecked + ) where + +import Conduit +import Network.HTTP.Client as Export (parseRequest) +import Network.HTTP.Client as Export (parseUrlThrow) +import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) +import qualified Network.HTTP.Client as HTTP (withResponse) +import Network.HTTP.Client.Internal as Export (setUri) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.HTTP.Simple as Export (HttpException (..), + Request, Response, + addRequestHeader, + defaultRequest, + getResponseBody, + getResponseHeaders, + getResponseStatus, + setRequestHeader) +import qualified Network.HTTP.Simple as HTTP hiding (withResponse) +import Network.HTTP.Types as Export (Header, HeaderName, + Status, hCacheControl, + hRange, ok200, + partialContent206, + statusCode) +import qualified Pantry.SHA256 as SHA256 +import Pantry.Types +import RIO +import qualified RIO.ByteString as B +import qualified RIO.Text as T + +setUserAgent :: Request -> Request +setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] + +withResponse + :: MonadUnliftIO m + => HTTP.Request + -> (Response BodyReader -> m a) + -> m a +withResponse req inner = withRunInIO $ \run -> do + manager <- getGlobalManager + HTTP.withResponse (setUserAgent req) manager (run . inner) + +httpSink + :: MonadUnliftIO m + => Request + -> (Response () -> ConduitT ByteString Void m a) + -> m a +httpSink req inner = HTTP.httpSink (setUserAgent req) inner + +httpSinkChecked + :: MonadUnliftIO m + => Text + -> Maybe SHA256 + -> Maybe FileSize + -> ConduitT ByteString Void m a + -> m (SHA256, FileSize, a) +httpSinkChecked url msha msize sink = do + req <- liftIO $ parseUrlThrow $ T.unpack url + httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize msize) + <*> ZipSink sink + where + checkSha mexpected = do + actual <- SHA256.sinkHash + for_ mexpected $ \expected -> unless (actual == expected) $ + throwIO $ DownloadInvalidSHA256 url Mismatch + { mismatchExpected = expected + , mismatchActual = actual + } + pure actual + checkSize mexpected = + loop 0 + where + loop accum = do + mbs <- await + case mbs of + Nothing -> + case mexpected of + Just (FileSize expected) | expected /= accum -> + throwIO $ DownloadInvalidSize url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum + } + _ -> pure (FileSize accum) + Just bs -> do + let accum' = accum + fromIntegral (B.length bs) + case mexpected of + Just (FileSize expected) + | accum' > expected -> + throwIO $ DownloadTooLarge url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum' + } + _ -> loop accum' diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs --- a/src/Pantry/Hackage.hs +++ b/src/Pantry/Hackage.hs @@ -1,671 +1,671 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -module Pantry.Hackage - ( updateHackageIndex - , forceUpdateHackageIndex - , DidUpdateOccur (..) - , RequireHackageIndex (..) - , hackageIndexTarballL - , getHackageTarball - , getHackageTarballKey - , getHackageCabalFile - , getHackagePackageVersions - , getHackagePackageVersionRevisions - , getHackageTypoCorrections - , UsePreferredVersions (..) - , HackageTarballResult(..) - ) where - -import RIO -import RIO.Process -import Pantry.Casa -import Data.Aeson -import Conduit -import Data.Conduit.Tar -import qualified RIO.Text as T -import qualified RIO.Map as Map -import Data.Text.Unsafe (unsafeTail) -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import Pantry.Archive -import Pantry.Types hiding (FileType (..)) -import Pantry.Storage hiding (TreeEntry, PackageName, Version) -import Pantry.Tree -import qualified Pantry.SHA256 as SHA256 -import Network.URI (parseURI) -import Data.Time (getCurrentTime) -import Path ((), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) -import qualified Distribution.Text -import qualified Distribution.PackageDescription as Cabal -import qualified Data.List.NonEmpty as NE -import Data.Text.Metrics (damerauLevenshtein) -#if !MIN_VERSION_rio(0,1,16) --- Now provided by RIO from the rio package. Resolvers before lts-15.16 --- (GHC 8.8.3) had rio < 0.1.16. -import System.IO (SeekMode (..)) -#endif -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.Types.Version (versionNumbers) -import Distribution.Types.VersionRange (withinRange) - -import qualified Hackage.Security.Client as HS -import qualified Hackage.Security.Client.Repository.Cache as HS -import qualified Hackage.Security.Client.Repository.Remote as HS -import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS -import qualified Hackage.Security.Util.Path as HS -import qualified Hackage.Security.Util.Pretty as HS - -hackageRelDir :: Path Rel Dir -hackageRelDir = either impureThrow id $ parseRelDir "hackage" - -hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) -hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) - -indexRelFile :: Path Rel File -indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" - --- | Where does pantry download its 01-index.tar file from Hackage? --- --- @since 0.1.0.0 -hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) -hackageIndexTarballL = hackageDirL.to ( indexRelFile) - --- | Did an update occur when running 'updateHackageIndex'? --- --- @since 0.1.0.0 -data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred - - --- | Information returned by `getHackageTarball` --- --- @since 0.1.0.0 -data HackageTarballResult = HackageTarballResult - { htrPackage :: !Package - -- ^ Package that was loaded from Hackage tarball - , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) - -- ^ This information is only available whenever package was just loaded into pantry. - } - --- | Download the most recent 01-index.tar file from Hackage and --- update the database tables. --- --- This function will only perform an update once per 'PantryConfig' --- for user sanity. See the return value to find out if it happened. --- --- @since 0.1.0.0 -updateHackageIndex - :: (HasPantryConfig env, HasLogFunc env) - => Maybe Utf8Builder -- ^ reason for updating, if any - -> RIO env DidUpdateOccur -updateHackageIndex = updateHackageIndexInternal False - --- | Same as `updateHackageIndex`, but force the database update even if hackage --- security tells that there is no change. This can be useful in order to make --- sure the database is in sync with the locally downloaded tarball --- --- @since 0.1.0.0 -forceUpdateHackageIndex - :: (HasPantryConfig env, HasLogFunc env) - => Maybe Utf8Builder - -> RIO env DidUpdateOccur -forceUpdateHackageIndex = updateHackageIndexInternal True - - -updateHackageIndexInternal - :: (HasPantryConfig env, HasLogFunc env) - => Bool -- ^ Force the database update. - -> Maybe Utf8Builder -- ^ reason for updating, if any - -> RIO env DidUpdateOccur -updateHackageIndexInternal forceUpdate mreason = do - storage <- view $ pantryConfigL.to pcStorage - gateUpdate $ withWriteLock_ storage $ do - for_ mreason logInfo - pc <- view pantryConfigL - let HackageSecurityConfig keyIds threshold url ignoreExpiry = pcHackageSecurity pc - root <- view hackageDirL - tarball <- view hackageIndexTarballL - baseURI <- - case parseURI $ T.unpack url of - Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url - Just x -> return x - run <- askRunInIO - let logTUF = run . logInfo . fromString . HS.pretty - withRepo = HS.withRepository - HS.httpLib - [baseURI] - HS.defaultRepoOpts - HS.Cache - { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root - , HS.cacheLayout = HS.cabalCacheLayout - } - HS.hackageRepoLayout - HS.hackageIndexLayout - logTUF - didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do - needBootstrap <- HS.requiresBootstrap repo - when needBootstrap $ do - HS.bootstrap - repo - (map (HS.KeyId . T.unpack) keyIds) - (HS.KeyThreshold $ fromIntegral threshold) - maybeNow <- if ignoreExpiry - then pure Nothing - else Just <$> getCurrentTime - HS.checkForUpdates repo maybeNow - - case didUpdate of - _ | forceUpdate -> do - logInfo "Forced package update is initialized" - updateCache tarball - HS.NoUpdates -> do - x <- needsCacheUpdate tarball - if x - then do - logInfo "No package index update available, but didn't update cache last time, running now" - updateCache tarball - else logInfo "No package index update available and cache up to date" - HS.HasUpdates -> do - logInfo "Updated package index downloaded" - updateCache tarball - logStickyDone "Package index cache populated" - where - -- The size of the new index tarball, ignoring the required - -- (by the tar spec) 1024 null bytes at the end, which will be - -- mutated in the future by other updates. - getTarballSize :: MonadIO m => Handle -> m Word - getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h - - -- Check if the size of the tarball on the disk matches the value - -- in CacheUpdate. If not, we need to perform a cache update, even - -- if we didn't download any new information. This can be caused - -- by canceling an updateCache call. - needsCacheUpdate tarball = do - mres <- withStorage loadLatestCacheUpdate - case mres of - Nothing -> pure True - Just (FileSize cachedSize, _sha256) -> do - actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize - pure $ cachedSize /= actualSize - - -- This is the one action in the Pantry codebase known to hold a - -- write lock on the database for an extended period of time. To - -- avoid failures due to SQLite locks failing, we take our own - -- lock outside of SQLite for this action. - -- - -- See https://github.com/commercialhaskell/stack/issues/4471 - updateCache tarball = withStorage $ do - -- Alright, here's the story. In theory, we only ever append to - -- a tarball. Therefore, we can store the last place we - -- populated our cache from, and fast forward to that point. But - -- there are two issues with that: - -- - -- 1. Hackage may rebase, in which case we need to recalculate - -- everything from the beginning. Unfortunately, - -- hackage-security doesn't let us know when that happens. - -- - -- 2. Some paranoia about files on the filesystem getting - -- modified out from under us. - -- - -- Therefore, we store both the last read-to index, _and_ the - -- SHA256 of all of the contents until that point. When updating - -- the cache, we calculate the new SHA256 of the whole file, and - -- the SHA256 of the previous read-to point. If the old hashes - -- match, we can do an efficient fast forward. Otherwise, we - -- clear the old cache and repopulate. - minfo <- loadLatestCacheUpdate - (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do - logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" - - newSize <- getTarballSize h - let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash - - case minfo of - Nothing -> do - logInfo "No old cache found, populating cache from scratch" - newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize - pure (0, newHash, newSize) - Just (FileSize oldSize, oldHash) -> do - -- oldSize and oldHash come from the database, and tell - -- us what we cached already. Compare against - -- oldHashCheck, which assuming the tarball has not been - -- rebased will be the same as oldHash. At the same - -- time, calculate newHash, which is the hash of the new - -- content as well. - (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) - <$> ZipSink (sinkSHA256 oldSize) - <*> ZipSink (sinkSHA256 newSize) - ) - offset <- - if oldHash == oldHashCheck - then oldSize <$ logInfo "Updating preexisting cache, should be quick" - else 0 <$ do - logWarn $ mconcat [ - "Package index change detected, that's pretty unusual: " - , "\n Old size: " <> display oldSize - , "\n Old hash (orig) : " <> display oldHash - , "\n New hash (check): " <> display oldHashCheck - , "\n Forcing a recache" - ] - pure (offset, newHash, newSize) - - lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash - when (offset == 0) clearHackageRevisions - populateCache tarball (fromIntegral offset) `onException` - lift (logStickyDone "Failed populating package index cache") - storeCacheUpdate (FileSize newSize) newHash - gateUpdate inner = do - pc <- view pantryConfigL - join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ - if toUpdate - then (False, UpdateOccurred <$ inner) - else (False, pure NoUpdateOccurred) - --- | Populate the SQLite tables with Hackage index information. -populateCache - :: (HasPantryConfig env, HasLogFunc env) - => Path Abs File -- ^ tarball - -> Integer -- ^ where to start processing from - -> ReaderT SqlBackend (RIO env) () -populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do - lift $ logInfo "Populating package index cache ..." - counter <- newIORef (0 :: Int) - hSeek h AbsoluteSeek offset - runConduit $ sourceHandle h .| untar (perFile counter) - where - - perFile counter fi - | FTNormal <- fileType fi - , Right path <- decodeUtf8' $ filePath fi - , Just (name, version, filename) <- parseNameVersionSuffix path = - if - | filename == "package.json" -> - sinkLazy >>= lift . addJSON name version - | filename == unSafeFilePath (cabalFileName name) -> do - (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version - - count <- readIORef counter - let count' = count + 1 - writeIORef counter count' - when (count' `mod` 400 == 0) $ - lift $ lift $ - logSticky $ "Processed " <> display count' <> " cabal files" - | otherwise -> pure () - | FTNormal <- fileType fi - , Right path <- decodeUtf8' $ filePath fi - , (nameT, "/preferred-versions") <- T.break (== '/') path - , Just name <- parsePackageName $ T.unpack nameT = do - lbs <- sinkLazy - case decodeUtf8' $ BL.toStrict lbs of - Left _ -> pure () -- maybe warning - Right p -> lift $ storePreferredVersion name p - | otherwise = pure () - - addJSON name version lbs = - case eitherDecode' lbs of - Left e -> lift $ logError $ - "Error processing Hackage security metadata for " <> - fromString (Distribution.Text.display name) <> "-" <> - fromString (Distribution.Text.display version) <> ": " <> - fromString e - Right (PackageDownload sha size) -> - storeHackageTarballInfo name version sha $ FileSize size - - addCabal name version bs = do - (blobTableId, _blobKey) <- storeBlob bs - - storeHackageRevision name version blobTableId - - breakSlash x - | T.null z = Nothing - | otherwise = Just (y, unsafeTail z) - where - (y, z) = T.break (== '/') x - - parseNameVersionSuffix t1 = do - (name, t2) <- breakSlash t1 - (version, filename) <- breakSlash t2 - - name' <- Distribution.Text.simpleParse $ T.unpack name - version' <- Distribution.Text.simpleParse $ T.unpack version - - Just (name', version', filename) - --- | Package download info from Hackage -data PackageDownload = PackageDownload !SHA256 !Word -instance FromJSON PackageDownload where - parseJSON = withObject "PackageDownload" $ \o1 -> do - o2 <- o1 .: "signed" - Object o3 <- o2 .: "targets" - Object o4:_ <- return $ toList o3 - len <- o4 .: "length" - hashes <- o4 .: "hashes" - sha256' <- hashes .: "sha256" - sha256 <- - case SHA256.fromHexText sha256' of - Left e -> fail $ "Invalid sha256: " ++ show e - Right x -> return x - return $ PackageDownload sha256 len - -getHackageCabalFile - :: (HasPantryConfig env, HasLogFunc env) - => PackageIdentifierRevision - -> RIO env ByteString -getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do - bid <- resolveCabalFileInfo pir - bs <- withStorage $ loadBlobById bid - case cfi of - CFIHash sha msize -> do - let sizeMismatch = - case msize of - Nothing -> False - Just size -> FileSize (fromIntegral (B.length bs)) /= size - shaMismatch = sha /= SHA256.hashBytes bs - when (sizeMismatch || shaMismatch) - $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) - _ -> pure () - pure bs - -resolveCabalFileInfo - :: (HasPantryConfig env, HasLogFunc env) - => PackageIdentifierRevision - -> RIO env BlobId -resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do - mres <- inner - case mres of - Just res -> pure res - Nothing -> do - updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" - mres' <- - case updated of - UpdateOccurred -> inner - NoUpdateOccurred -> pure Nothing - case mres' of - Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir - Just res -> pure res - where - inner = - case cfi of - CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize - CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) - CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) - --- | Load or download a blob by its SHA. -loadOrDownloadBlobBySHA :: - (Display a, HasPantryConfig env, HasLogFunc env) - => a - -> SHA256 - -> Maybe FileSize - -> RIO env (Maybe BlobId) -loadOrDownloadBlobBySHA label sha256 msize = do - mresult <- byDB - case mresult of - Nothing -> do - case msize of - Nothing -> do - pure Nothing - Just size -> do - mblob <- casaLookupKey (BlobKey sha256 size) - case mblob of - Nothing -> do - pure Nothing - Just {} -> do - result <- byDB - case result of - Just blobId -> do - logDebug ("Pulled blob from Casa for " <> display label) - pure (Just blobId) - Nothing -> do - logWarn - ("Bug? Blob pulled from Casa not in database for " <> - display label) - pure Nothing - Just blobId -> do - logDebug ("Got blob from Pantry database for " <> display label) - pure (Just blobId) - where - byDB = withStorage $ loadBlobBySHA sha256 - --- | Given package identifier and package caches, return list of packages --- with the same name and the same two first version number components found --- in the caches. -fuzzyLookupCandidates - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> Version - -> RIO env FuzzyResults -fuzzyLookupCandidates name ver0 = do - m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name - if Map.null m - then FRNameNotFound <$> getHackageTypoCorrections name - else - case Map.lookup ver0 m of - Nothing -> do - let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> - case Map.maxView revs of - Nothing -> error "fuzzyLookupCandidates: no revisions" - Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) - case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of - Just vers -> withVers vers - Nothing -> - case NE.nonEmpty $ Map.toList m of - Nothing -> error "fuzzyLookupCandidates: no versions" - Just vers -> withVers vers - Just revisions -> - let pirs = map - (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) - (Map.elems revisions) - in case NE.nonEmpty pirs of - Nothing -> error "fuzzyLookupCandidates: no revisions" - Just pirs' -> pure $ FRRevisionNotFound pirs' - where - sameMajor v = toMajorVersion v == toMajorVersion ver0 - -toMajorVersion :: Version -> [Int] -toMajorVersion v = - case versionNumbers v of - [] -> [0, 0] - [a] -> [a, 0] - a:b:_ -> [a, b] - --- | Try to come up with typo corrections for given package identifier --- using Hackage package names. This can provide more user-friendly --- information in error messages. --- --- @since 0.1.0.0 -getHackageTypoCorrections - :: (HasPantryConfig env, HasLogFunc env) - => PackageName - -> RIO env [PackageName] -getHackageTypoCorrections name1 = - withStorage $ sinkHackagePackageNames - (\name2 -> name1 `distance` name2 < 4) - (takeC 10 .| sinkList) - where - distance = damerauLevenshtein `on` (T.pack . packageNameString) - --- | Should we pay attention to Hackage's preferred versions? --- --- @since 0.1.0.0 -data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions - deriving Show - --- | Require that the Hackage index is populated. --- --- @since 0.1.0.0 -data RequireHackageIndex - = YesRequireHackageIndex - -- ^ If there is nothing in the Hackage index, then perform an update - | NoRequireHackageIndex - -- ^ Do not perform an update - deriving Show - -initializeIndex - :: (HasPantryConfig env, HasLogFunc env) - => RequireHackageIndex - -> RIO env () -initializeIndex NoRequireHackageIndex = pure () -initializeIndex YesRequireHackageIndex = do - cabalCount <- withStorage countHackageCabals - when (cabalCount == 0) $ void $ - updateHackageIndex $ Just $ "No information from Hackage index, updating" - --- | Returns the versions of the package available on Hackage. --- --- @since 0.1.0.0 -getHackagePackageVersions - :: (HasPantryConfig env, HasLogFunc env) - => RequireHackageIndex - -> UsePreferredVersions - -> PackageName -- ^ package name - -> RIO env (Map Version (Map Revision BlobKey)) -getHackagePackageVersions req usePreferred name = do - initializeIndex req - withStorage $ do - mpreferred <- - case usePreferred of - UsePreferredVersions -> loadPreferredVersion name - IgnorePreferredVersions -> pure Nothing - let predicate :: Version -> Map Revision BlobKey -> Bool - predicate = fromMaybe (\_ _ -> True) $ do - preferredT1 <- mpreferred - preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 - vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 - Just $ \v _ -> withinRange v vr - Map.filterWithKey predicate <$> loadHackagePackageVersions name - --- | Returns the versions of the package available on Hackage. --- --- @since 0.1.0.0 -getHackagePackageVersionRevisions - :: (HasPantryConfig env, HasLogFunc env) - => RequireHackageIndex - -> PackageName -- ^ package name - -> Version -- ^ package version - -> RIO env (Map Revision BlobKey) -getHackagePackageVersionRevisions req name version = do - initializeIndex req - withStorage $ - Map.map snd <$> loadHackagePackageVersion name version - -withCachedTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocationImmutable - -> PackageName - -> Version - -> BlobId -- ^ cabal file contents - -> RIO env HackageTarballResult - -> RIO env HackageTarballResult -withCachedTree rpli name ver bid inner = do - mres <- withStorage $ loadHackageTree rpli name ver bid - case mres of - Just package -> pure $ HackageTarballResult package Nothing - Nothing -> do - htr <- inner - withStorage $ - storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr - pure htr - -getHackageTarballKey - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageIdentifierRevision - -> RIO env TreeKey -getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do - mres <- withStorage $ loadHackageTreeKey name ver sha - case mres of - Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing - Just key -> pure key -getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing - -getHackageTarball - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => PackageIdentifierRevision - -> Maybe TreeKey - -> RIO env HackageTarballResult -getHackageTarball pir mtreeKey = do - let PackageIdentifierRevision name ver _cfi = pir - cabalFile <- resolveCabalFileInfo pir - let rpli = RPLIHackage pir mtreeKey - withCachedTree rpli name ver cabalFile $ do - cabalFileKey <- withStorage $ getBlobKey cabalFile - mpair <- withStorage $ loadHackageTarballInfo name ver - (sha, size) <- - case mpair of - Just pair -> pure pair - Nothing -> do - let exc = NoHackageCryptographicHash $ PackageIdentifier name ver - updated <- updateHackageIndex $ Just $ display exc <> ", updating" - mpair2 <- - case updated of - UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver - NoUpdateOccurred -> pure Nothing - case mpair2 of - Nothing -> throwIO exc - Just pair2 -> pure pair2 - pc <- view pantryConfigL - let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc - url = - mconcat - [ urlPrefix - , "package/" - , T.pack $ Distribution.Text.display name - , "-" - , T.pack $ Distribution.Text.display ver - , ".tar.gz" - ] - (_, _, package, cachedTree) <- - getArchive - rpli - RawArchive - { raLocation = ALUrl url - , raHash = Just sha - , raSize = Just size - , raSubdir = T.empty -- no subdirs on Hackage - } - RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just ver - , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree - } - case cachedTree of - CachedTreeMap m -> do - let ft = - case packageCabalEntry package of - PCCabalFile (TreeEntry _ ft') -> ft' - _ -> error "Impossible: Hackage does not support hpack" - cabalEntry = TreeEntry cabalFileKey ft - (cabalBS, cabalBlobId) <- - withStorage $ do - let BlobKey sha' _ = cabalFileKey - mcabalBS <- loadBlobBySHA sha' - case mcabalBS of - Nothing -> - error $ - "Invariant violated, cabal file key: " ++ show cabalFileKey - Just bid -> (, bid) <$> loadBlobById bid - let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m - ident = PackageIdentifier name ver - (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS - let gpdIdent = Cabal.package $ Cabal.packageDescription gpd - when (ident /= gpdIdent) $ - throwIO $ - MismatchedCabalFileForHackage - pir - Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} - (tid, treeKey') <- - withStorage $ - storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) - pure - HackageTarballResult - { htrPackage = - Package - { packageTreeKey = treeKey' - , packageTree = unCachedTree tree' - , packageIdent = ident - , packageCabalEntry = PCCabalFile cabalEntry - } - , htrFreshPackageInfo = Just (gpd, tid) - } +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Pantry.Hackage + ( updateHackageIndex + , forceUpdateHackageIndex + , DidUpdateOccur (..) + , RequireHackageIndex (..) + , hackageIndexTarballL + , getHackageTarball + , getHackageTarballKey + , getHackageCabalFile + , getHackagePackageVersions + , getHackagePackageVersionRevisions + , getHackageTypoCorrections + , UsePreferredVersions (..) + , HackageTarballResult(..) + ) where + +import RIO +import RIO.Process +import Pantry.Casa +import Data.Aeson +import Conduit +import Data.Conduit.Tar +import qualified RIO.Text as T +import qualified RIO.Map as Map +import Data.Text.Unsafe (unsafeTail) +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import Pantry.Archive +import Pantry.Types hiding (FileType (..)) +import Pantry.Storage hiding (TreeEntry, PackageName, Version) +import Pantry.Tree +import qualified Pantry.SHA256 as SHA256 +import Network.URI (parseURI) +import Data.Time (getCurrentTime) +import Path ((), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) +import qualified Distribution.Text +import qualified Distribution.PackageDescription as Cabal +import qualified Data.List.NonEmpty as NE +import Data.Text.Metrics (damerauLevenshtein) +#if !MIN_VERSION_rio(0,1,16) +-- Now provided by RIO from the rio package. Resolvers before lts-15.16 +-- (GHC 8.8.3) had rio < 0.1.16. +import System.IO (SeekMode (..)) +#endif +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.Types.Version (versionNumbers) +import Distribution.Types.VersionRange (withinRange) + +import qualified Hackage.Security.Client as HS +import qualified Hackage.Security.Client.Repository.Cache as HS +import qualified Hackage.Security.Client.Repository.Remote as HS +import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS +import qualified Hackage.Security.Util.Path as HS +import qualified Hackage.Security.Util.Pretty as HS + +hackageRelDir :: Path Rel Dir +hackageRelDir = either impureThrow id $ parseRelDir "hackage" + +hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) +hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) + +indexRelFile :: Path Rel File +indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" + +-- | Where does pantry download its 01-index.tar file from Hackage? +-- +-- @since 0.1.0.0 +hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) +hackageIndexTarballL = hackageDirL.to ( indexRelFile) + +-- | Did an update occur when running 'updateHackageIndex'? +-- +-- @since 0.1.0.0 +data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred + + +-- | Information returned by `getHackageTarball` +-- +-- @since 0.1.0.0 +data HackageTarballResult = HackageTarballResult + { htrPackage :: !Package + -- ^ Package that was loaded from Hackage tarball + , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) + -- ^ This information is only available whenever package was just loaded into pantry. + } + +-- | Download the most recent 01-index.tar file from Hackage and +-- update the database tables. +-- +-- This function will only perform an update once per 'PantryConfig' +-- for user sanity. See the return value to find out if it happened. +-- +-- @since 0.1.0.0 +updateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndex = updateHackageIndexInternal False + +-- | Same as `updateHackageIndex`, but force the database update even if hackage +-- security tells that there is no change. This can be useful in order to make +-- sure the database is in sync with the locally downloaded tarball +-- +-- @since 0.1.0.0 +forceUpdateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder + -> RIO env DidUpdateOccur +forceUpdateHackageIndex = updateHackageIndexInternal True + + +updateHackageIndexInternal + :: (HasPantryConfig env, HasLogFunc env) + => Bool -- ^ Force the database update. + -> Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndexInternal forceUpdate mreason = do + storage <- view $ pantryConfigL.to pcStorage + gateUpdate $ withWriteLock_ storage $ do + for_ mreason logInfo + pc <- view pantryConfigL + let HackageSecurityConfig keyIds threshold url ignoreExpiry = pcHackageSecurity pc + root <- view hackageDirL + tarball <- view hackageIndexTarballL + baseURI <- + case parseURI $ T.unpack url of + Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url + Just x -> return x + run <- askRunInIO + let logTUF = run . logInfo . fromString . HS.pretty + withRepo = HS.withRepository + HS.httpLib + [baseURI] + HS.defaultRepoOpts + HS.Cache + { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root + , HS.cacheLayout = HS.cabalCacheLayout + } + HS.hackageRepoLayout + HS.hackageIndexLayout + logTUF + didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do + needBootstrap <- HS.requiresBootstrap repo + when needBootstrap $ do + HS.bootstrap + repo + (map (HS.KeyId . T.unpack) keyIds) + (HS.KeyThreshold $ fromIntegral threshold) + maybeNow <- if ignoreExpiry + then pure Nothing + else Just <$> getCurrentTime + HS.checkForUpdates repo maybeNow + + case didUpdate of + _ | forceUpdate -> do + logInfo "Forced package update is initialized" + updateCache tarball + HS.NoUpdates -> do + x <- needsCacheUpdate tarball + if x + then do + logInfo "No package index update available, but didn't update cache last time, running now" + updateCache tarball + else logInfo "No package index update available and cache up to date" + HS.HasUpdates -> do + logInfo "Updated package index downloaded" + updateCache tarball + logStickyDone "Package index cache populated" + where + -- The size of the new index tarball, ignoring the required + -- (by the tar spec) 1024 null bytes at the end, which will be + -- mutated in the future by other updates. + getTarballSize :: MonadIO m => Handle -> m Word + getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + + -- Check if the size of the tarball on the disk matches the value + -- in CacheUpdate. If not, we need to perform a cache update, even + -- if we didn't download any new information. This can be caused + -- by canceling an updateCache call. + needsCacheUpdate tarball = do + mres <- withStorage loadLatestCacheUpdate + case mres of + Nothing -> pure True + Just (FileSize cachedSize, _sha256) -> do + actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize + pure $ cachedSize /= actualSize + + -- This is the one action in the Pantry codebase known to hold a + -- write lock on the database for an extended period of time. To + -- avoid failures due to SQLite locks failing, we take our own + -- lock outside of SQLite for this action. + -- + -- See https://github.com/commercialhaskell/stack/issues/4471 + updateCache tarball = withStorage $ do + -- Alright, here's the story. In theory, we only ever append to + -- a tarball. Therefore, we can store the last place we + -- populated our cache from, and fast forward to that point. But + -- there are two issues with that: + -- + -- 1. Hackage may rebase, in which case we need to recalculate + -- everything from the beginning. Unfortunately, + -- hackage-security doesn't let us know when that happens. + -- + -- 2. Some paranoia about files on the filesystem getting + -- modified out from under us. + -- + -- Therefore, we store both the last read-to index, _and_ the + -- SHA256 of all of the contents until that point. When updating + -- the cache, we calculate the new SHA256 of the whole file, and + -- the SHA256 of the previous read-to point. If the old hashes + -- match, we can do an efficient fast forward. Otherwise, we + -- clear the old cache and repopulate. + minfo <- loadLatestCacheUpdate + (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do + logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" + + newSize <- getTarballSize h + let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash + + case minfo of + Nothing -> do + logInfo "No old cache found, populating cache from scratch" + newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize + pure (0, newHash, newSize) + Just (FileSize oldSize, oldHash) -> do + -- oldSize and oldHash come from the database, and tell + -- us what we cached already. Compare against + -- oldHashCheck, which assuming the tarball has not been + -- rebased will be the same as oldHash. At the same + -- time, calculate newHash, which is the hash of the new + -- content as well. + (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (sinkSHA256 oldSize) + <*> ZipSink (sinkSHA256 newSize) + ) + offset <- + if oldHash == oldHashCheck + then oldSize <$ logInfo "Updating preexisting cache, should be quick" + else 0 <$ do + logWarn $ mconcat [ + "Package index change detected, that's pretty unusual: " + , "\n Old size: " <> display oldSize + , "\n Old hash (orig) : " <> display oldHash + , "\n New hash (check): " <> display oldHashCheck + , "\n Forcing a recache" + ] + pure (offset, newHash, newSize) + + lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash + when (offset == 0) clearHackageRevisions + populateCache tarball (fromIntegral offset) `onException` + lift (logStickyDone "Failed populating package index cache") + storeCacheUpdate (FileSize newSize) newHash + gateUpdate inner = do + pc <- view pantryConfigL + join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ + if toUpdate + then (False, UpdateOccurred <$ inner) + else (False, pure NoUpdateOccurred) + +-- | Populate the SQLite tables with Hackage index information. +populateCache + :: (HasPantryConfig env, HasLogFunc env) + => Path Abs File -- ^ tarball + -> Integer -- ^ where to start processing from + -> ReaderT SqlBackend (RIO env) () +populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do + lift $ logInfo "Populating package index cache ..." + counter <- newIORef (0 :: Int) + hSeek h AbsoluteSeek offset + runConduit $ sourceHandle h .| untar (perFile counter) + where + + perFile counter fi + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , Just (name, version, filename) <- parseNameVersionSuffix path = + if + | filename == "package.json" -> + sinkLazy >>= lift . addJSON name version + | filename == unSafeFilePath (cabalFileName name) -> do + (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version + + count <- readIORef counter + let count' = count + 1 + writeIORef counter count' + when (count' `mod` 400 == 0) $ + lift $ lift $ + logSticky $ "Processed " <> display count' <> " cabal files" + | otherwise -> pure () + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , (nameT, "/preferred-versions") <- T.break (== '/') path + , Just name <- parsePackageName $ T.unpack nameT = do + lbs <- sinkLazy + case decodeUtf8' $ BL.toStrict lbs of + Left _ -> pure () -- maybe warning + Right p -> lift $ storePreferredVersion name p + | otherwise = pure () + + addJSON name version lbs = + case eitherDecode' lbs of + Left e -> lift $ logError $ + "Error processing Hackage security metadata for " <> + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display version) <> ": " <> + fromString e + Right (PackageDownload sha size) -> + storeHackageTarballInfo name version sha $ FileSize size + + addCabal name version bs = do + (blobTableId, _blobKey) <- storeBlob bs + + storeHackageRevision name version blobTableId + + breakSlash x + | T.null z = Nothing + | otherwise = Just (y, unsafeTail z) + where + (y, z) = T.break (== '/') x + + parseNameVersionSuffix t1 = do + (name, t2) <- breakSlash t1 + (version, filename) <- breakSlash t2 + + name' <- Distribution.Text.simpleParse $ T.unpack name + version' <- Distribution.Text.simpleParse $ T.unpack version + + Just (name', version', filename) + +-- | Package download info from Hackage +data PackageDownload = PackageDownload !SHA256 !Word +instance FromJSON PackageDownload where + parseJSON = withObject "PackageDownload" $ \o1 -> do + o2 <- o1 .: "signed" + Object o3 <- o2 .: "targets" + Object o4:_ <- return $ toList o3 + len <- o4 .: "length" + hashes <- o4 .: "hashes" + sha256' <- hashes .: "sha256" + sha256 <- + case SHA256.fromHexText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> return x + return $ PackageDownload sha256 len + +getHackageCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env ByteString +getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do + bid <- resolveCabalFileInfo pir + bs <- withStorage $ loadBlobById bid + case cfi of + CFIHash sha msize -> do + let sizeMismatch = + case msize of + Nothing -> False + Just size -> FileSize (fromIntegral (B.length bs)) /= size + shaMismatch = sha /= SHA256.hashBytes bs + when (sizeMismatch || shaMismatch) + $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) + _ -> pure () + pure bs + +resolveCabalFileInfo + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env BlobId +resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do + mres <- inner + case mres of + Just res -> pure res + Nothing -> do + updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" + mres' <- + case updated of + UpdateOccurred -> inner + NoUpdateOccurred -> pure Nothing + case mres' of + Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir + Just res -> pure res + where + inner = + case cfi of + CFIHash sha msize -> loadOrDownloadBlobBySHA pir sha msize + CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) + CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) + +-- | Load or download a blob by its SHA. +loadOrDownloadBlobBySHA :: + (Display a, HasPantryConfig env, HasLogFunc env) + => a + -> SHA256 + -> Maybe FileSize + -> RIO env (Maybe BlobId) +loadOrDownloadBlobBySHA label sha256 msize = do + mresult <- byDB + case mresult of + Nothing -> do + case msize of + Nothing -> do + pure Nothing + Just size -> do + mblob <- casaLookupKey (BlobKey sha256 size) + case mblob of + Nothing -> do + pure Nothing + Just {} -> do + result <- byDB + case result of + Just blobId -> do + logDebug ("Pulled blob from Casa for " <> display label) + pure (Just blobId) + Nothing -> do + logWarn + ("Bug? Blob pulled from Casa not in database for " <> + display label) + pure Nothing + Just blobId -> do + logDebug ("Got blob from Pantry database for " <> display label) + pure (Just blobId) + where + byDB = withStorage $ loadBlobBySHA sha256 + +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> RIO env FuzzyResults +fuzzyLookupCandidates name ver0 = do + m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name + if Map.null m + then FRNameNotFound <$> getHackageTypoCorrections name + else + case Map.lookup ver0 m of + Nothing -> do + let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> + case Map.maxView revs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) + case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of + Just vers -> withVers vers + Nothing -> + case NE.nonEmpty $ Map.toList m of + Nothing -> error "fuzzyLookupCandidates: no versions" + Just vers -> withVers vers + Just revisions -> + let pirs = map + (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) + (Map.elems revisions) + in case NE.nonEmpty pirs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just pirs' -> pure $ FRRevisionNotFound pirs' + where + sameMajor v = toMajorVersion v == toMajorVersion ver0 + +toMajorVersion :: Version -> [Int] +toMajorVersion v = + case versionNumbers v of + [] -> [0, 0] + [a] -> [a, 0] + a:b:_ -> [a, b] + +-- | Try to come up with typo corrections for given package identifier +-- using Hackage package names. This can provide more user-friendly +-- information in error messages. +-- +-- @since 0.1.0.0 +getHackageTypoCorrections + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> RIO env [PackageName] +getHackageTypoCorrections name1 = + withStorage $ sinkHackagePackageNames + (\name2 -> name1 `distance` name2 < 4) + (takeC 10 .| sinkList) + where + distance = damerauLevenshtein `on` (T.pack . packageNameString) + +-- | Should we pay attention to Hackage's preferred versions? +-- +-- @since 0.1.0.0 +data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions + deriving Show + +-- | Require that the Hackage index is populated. +-- +-- @since 0.1.0.0 +data RequireHackageIndex + = YesRequireHackageIndex + -- ^ If there is nothing in the Hackage index, then perform an update + | NoRequireHackageIndex + -- ^ Do not perform an update + deriving Show + +initializeIndex + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> RIO env () +initializeIndex NoRequireHackageIndex = pure () +initializeIndex YesRequireHackageIndex = do + cabalCount <- withStorage countHackageCabals + when (cabalCount == 0) $ void $ + updateHackageIndex $ Just $ "No information from Hackage index, updating" + +-- | Returns the versions of the package available on Hackage. +-- +-- @since 0.1.0.0 +getHackagePackageVersions + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> UsePreferredVersions + -> PackageName -- ^ package name + -> RIO env (Map Version (Map Revision BlobKey)) +getHackagePackageVersions req usePreferred name = do + initializeIndex req + withStorage $ do + mpreferred <- + case usePreferred of + UsePreferredVersions -> loadPreferredVersion name + IgnorePreferredVersions -> pure Nothing + let predicate :: Version -> Map Revision BlobKey -> Bool + predicate = fromMaybe (\_ _ -> True) $ do + preferredT1 <- mpreferred + preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 + vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 + Just $ \v _ -> withinRange v vr + Map.filterWithKey predicate <$> loadHackagePackageVersions name + +-- | Returns the versions of the package available on Hackage. +-- +-- @since 0.1.0.0 +getHackagePackageVersionRevisions + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> Version -- ^ package version + -> RIO env (Map Revision BlobKey) +getHackagePackageVersionRevisions req name version = do + initializeIndex req + withStorage $ + Map.map snd <$> loadHackagePackageVersion name version + +withCachedTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> PackageName + -> Version + -> BlobId -- ^ cabal file contents + -> RIO env HackageTarballResult + -> RIO env HackageTarballResult +withCachedTree rpli name ver bid inner = do + mres <- withStorage $ loadHackageTree rpli name ver bid + case mres of + Just package -> pure $ HackageTarballResult package Nothing + Nothing -> do + htr <- inner + withStorage $ + storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr + pure htr + +getHackageTarballKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageIdentifierRevision + -> RIO env TreeKey +getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do + mres <- withStorage $ loadHackageTreeKey name ver sha + case mres of + Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing + Just key -> pure key +getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing + +getHackageTarball + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageIdentifierRevision + -> Maybe TreeKey + -> RIO env HackageTarballResult +getHackageTarball pir mtreeKey = do + let PackageIdentifierRevision name ver _cfi = pir + cabalFile <- resolveCabalFileInfo pir + let rpli = RPLIHackage pir mtreeKey + withCachedTree rpli name ver cabalFile $ do + cabalFileKey <- withStorage $ getBlobKey cabalFile + mpair <- withStorage $ loadHackageTarballInfo name ver + (sha, size) <- + case mpair of + Just pair -> pure pair + Nothing -> do + let exc = NoHackageCryptographicHash $ PackageIdentifier name ver + updated <- updateHackageIndex $ Just $ display exc <> ", updating" + mpair2 <- + case updated of + UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver + NoUpdateOccurred -> pure Nothing + case mpair2 of + Nothing -> throwIO exc + Just pair2 -> pure pair2 + pc <- view pantryConfigL + let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc + url = + mconcat + [ urlPrefix + , "package/" + , T.pack $ Distribution.Text.display name + , "-" + , T.pack $ Distribution.Text.display ver + , ".tar.gz" + ] + (_, _, package, cachedTree) <- + getArchive + rpli + RawArchive + { raLocation = ALUrl url + , raHash = Just sha + , raSize = Just size + , raSubdir = T.empty -- no subdirs on Hackage + } + RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just ver + , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree + } + case cachedTree of + CachedTreeMap m -> do + let ft = + case packageCabalEntry package of + PCCabalFile (TreeEntry _ ft') -> ft' + _ -> error "Impossible: Hackage does not support hpack" + cabalEntry = TreeEntry cabalFileKey ft + (cabalBS, cabalBlobId) <- + withStorage $ do + let BlobKey sha' _ = cabalFileKey + mcabalBS <- loadBlobBySHA sha' + case mcabalBS of + Nothing -> + error $ + "Invariant violated, cabal file key: " ++ show cabalFileKey + Just bid -> (, bid) <$> loadBlobById bid + let tree' = CachedTreeMap $ Map.insert (cabalFileName name) (cabalEntry, cabalBlobId) m + ident = PackageIdentifier name ver + (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS + let gpdIdent = Cabal.package $ Cabal.packageDescription gpd + when (ident /= gpdIdent) $ + throwIO $ + MismatchedCabalFileForHackage + pir + Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} + (tid, treeKey') <- + withStorage $ + storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + pure + HackageTarballResult + { htrPackage = + Package + { packageTreeKey = treeKey' + , packageTree = unCachedTree tree' + , packageIdent = ident + , packageCabalEntry = PCCabalFile cabalEntry + } + , htrFreshPackageInfo = Just (gpd, tid) + } diff --git a/src/Pantry/Internal.hs b/src/Pantry/Internal.hs --- a/src/Pantry/Internal.hs +++ b/src/Pantry/Internal.hs @@ -1,84 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Exposed for testing, do not use! -module Pantry.Internal - ( parseTree - , renderTree - , Tree (..) - , TreeEntry (..) - , FileType(..) - , mkSafeFilePath - , pcHpackExecutable - , normalizeParents - , makeTarRelative - , getGlobalHintsFile - , hpackVersion - , Storage - , initStorage - , withStorage_ - ) where - -import Control.Exception (assert) -import Pantry.Types -import Pantry.SQLite (initStorage) -import Pantry.HPack (hpackVersion) -import qualified Data.Text as T -import Data.Maybe (fromMaybe) - --- | Like @System.FilePath.normalise@, however: --- --- * Only works on relative paths, absolute paths fail --- --- * Strips trailing slashes --- --- * Only works on forward slashes, even on Windows --- --- * Normalizes parent dirs @foo/../@ get stripped --- --- * Cannot begin with a parent directory (@../@) --- --- * Spelled like an American, sorry -normalizeParents - :: FilePath - -> Either String FilePath -normalizeParents "" = Left "empty file path" -normalizeParents ('/':_) = Left "absolute path" -normalizeParents ('.':'.':'/':_) = Left "absolute path" -normalizeParents fp = do - -- Strip a single trailing, but not multiple - let t0 = T.pack fp - t = fromMaybe t0 $ T.stripSuffix "/" t0 - case T.unsnoc t of - Just (_, '/') -> Left "multiple trailing slashes" - _ -> Right () - - let c1 = T.split (== '/') t - - case reverse c1 of - ".":_ -> Left "last component is a single dot" - _ -> Right () - - let c2 = filter (\x -> not (T.null x || x == ".")) c1 - - let loop [] routput = reverse routput - loop ("..":rest) (_:routput) = loop rest routput - loop (x:xs) routput = loop xs (x:routput) - - case loop c2 [] of - [] -> Left "no non-empty components" - c' -> Right $ T.unpack $ T.intercalate "/" c' - --- | Following tar file rules (Unix file paths only), make the second --- file relative to the first file. -makeTarRelative - :: FilePath -- ^ base file - -> FilePath -- ^ relative part - -> Either String FilePath -makeTarRelative _ ('/':_) = Left "absolute path found" -makeTarRelative base rel = - case reverse base of - [] -> Left "cannot have empty base" - '/':_ -> Left "base cannot be a directory" - _:rest -> Right $ - case dropWhile (/= '/') rest of - '/':rest' -> reverse rest' ++ '/' : rel - rest' -> assert (null rest') rel +{-# LANGUAGE OverloadedStrings #-} +-- | Exposed for testing, do not use! +module Pantry.Internal + ( parseTree + , renderTree + , Tree (..) + , TreeEntry (..) + , FileType(..) + , mkSafeFilePath + , pcHpackExecutable + , normalizeParents + , makeTarRelative + , getGlobalHintsFile + , hpackVersion + , Storage + , initStorage + , withStorage_ + ) where + +import Control.Exception (assert) +import Pantry.Types +import Pantry.SQLite (initStorage) +import Pantry.HPack (hpackVersion) +import qualified Data.Text as T +import Data.Maybe (fromMaybe) + +-- | Like @System.FilePath.normalise@, however: +-- +-- * Only works on relative paths, absolute paths fail +-- +-- * Strips trailing slashes +-- +-- * Only works on forward slashes, even on Windows +-- +-- * Normalizes parent dirs @foo/../@ get stripped +-- +-- * Cannot begin with a parent directory (@../@) +-- +-- * Spelled like an American, sorry +normalizeParents + :: FilePath + -> Either String FilePath +normalizeParents "" = Left "empty file path" +normalizeParents ('/':_) = Left "absolute path" +normalizeParents ('.':'.':'/':_) = Left "absolute path" +normalizeParents fp = do + -- Strip a single trailing, but not multiple + let t0 = T.pack fp + t = fromMaybe t0 $ T.stripSuffix "/" t0 + case T.unsnoc t of + Just (_, '/') -> Left "multiple trailing slashes" + _ -> Right () + + let c1 = T.split (== '/') t + + case reverse c1 of + ".":_ -> Left "last component is a single dot" + _ -> Right () + + let c2 = filter (\x -> not (T.null x || x == ".")) c1 + + let loop [] routput = reverse routput + loop ("..":rest) (_:routput) = loop rest routput + loop (x:xs) routput = loop xs (x:routput) + + case loop c2 [] of + [] -> Left "no non-empty components" + c' -> Right $ T.unpack $ T.intercalate "/" c' + +-- | Following tar file rules (Unix file paths only), make the second +-- file relative to the first file. +makeTarRelative + :: FilePath -- ^ base file + -> FilePath -- ^ relative part + -> Either String FilePath +makeTarRelative _ ('/':_) = Left "absolute path found" +makeTarRelative base rel = + case reverse base of + [] -> Left "cannot have empty base" + '/':_ -> Left "base cannot be a directory" + _:rest -> Right $ + case dropWhile (/= '/') rest of + '/':rest' -> reverse rest' ++ '/' : rel + rest' -> assert (null rest') rel diff --git a/src/Pantry/Internal/AesonExtended.hs b/src/Pantry/Internal/AesonExtended.hs --- a/src/Pantry/Internal/AesonExtended.hs +++ b/src/Pantry/Internal/AesonExtended.hs @@ -1,238 +1,238 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} - --- | Extensions to Aeson parsing of objects. This module is intended --- for internal use by Pantry and Stack only. The intention is to --- fully remove this module in the future. /DO NOT RELY ON IT/. -module Pantry.Internal.AesonExtended ( - module Export - -- * Extended failure messages - , (.:) - , (.:?) - -- * JSON Parser that emits warnings - , JSONWarning (..) - , WarningParser - , WithJSONWarnings (..) - , withObjectWarnings - , jsonSubWarnings - , jsonSubWarningsT - , jsonSubWarningsTT - , logJSONWarnings - , noJSONWarnings - , tellJSONField - , unWarningParser - , (..:) - , (...:) - , (..:?) - , (...:?) - , (..!=) - ) where - -import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) -import Data.Aeson as Export hiding ((.:), (.:?)) -import qualified Data.Aeson as A -import Data.Aeson.Types hiding ((.:), (.:?)) -import qualified Data.Set as Set -import Data.Text (unpack) -import qualified Data.Text as T -import Generics.Deriving.Monoid (mappenddefault, memptydefault) -import RIO -import RIO.PrettyPrint.StylesUpdate (StylesUpdate) - -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.Key -import qualified Data.Aeson.KeyMap as HashMap - -keyToText :: Data.Aeson.Key.Key -> Text -keyToText = Data.Aeson.Key.toText - -textToKey :: Text -> Data.Aeson.Key.Key -textToKey = Data.Aeson.Key.fromText -#else -import qualified Data.HashMap.Strict as HashMap - -keyToText :: Text -> Text -keyToText = id - -textToKey :: Text -> Text -textToKey = id -#endif - --- | Extends @.:@ warning to include field name. -(.:) :: FromJSON a => Object -> Text -> Parser a -(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: textToKey p) -{-# INLINE (.:) #-} - --- | Extends @.:?@ warning to include field name. -(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) -(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? textToKey p) -{-# INLINE (.:?) #-} - --- | 'WarningParser' version of @.:@. -(..:) - :: FromJSON a - => Object -> Text -> WarningParser a -o ..: k = tellJSONField k >> lift (o .: k) - --- | 'WarningParser' version of @.:?@. -(..:?) - :: FromJSON a - => Object -> Text -> WarningParser (Maybe a) -o ..:? k = tellJSONField k >> lift (o .:? k) - --- | 'WarningParser' version of @.!=@. -(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a -wp ..!= d = - flip mapWriterT wp $ - \p -> - do a <- fmap snd p - fmap (, a) (fmap fst p .!= d) - -presentCount :: Object -> [Text] -> Int -presentCount o ss = length . filter (\x -> HashMap.member (textToKey x) o) $ ss - --- | Synonym version of @..:@. -(...:) :: FromJSON a => Object -> [Text] -> WarningParser a -_ ...: [] = fail "failed to find an empty key" -o ...: ss@(key:_) = apply - where pc = presentCount o ss - apply | pc == 0 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "keys " ++ show ss ++ " not present" - | pc > 1 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "two or more synonym keys " ++ - show ss ++ " present" - | otherwise = asum $ map (o..:) ss - --- | Synonym version of @..:?@. -(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a) -_ ...:? [] = fail "failed to find an empty key" -o ...:? ss@(key:_) = apply - where pc = presentCount o ss - apply | pc == 0 = return Nothing - | pc > 1 = fail $ - "failed to parse field " ++ - show key ++ ": " ++ - "two or more synonym keys " ++ - show ss ++ " present" - | otherwise = asum $ map (o..:) ss - --- | Tell warning parser about an expected field, so it doesn't warn about it. -tellJSONField :: Text -> WarningParser () -tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) - --- | 'WarningParser' version of 'withObject'. -withObjectWarnings :: String - -> (Object -> WarningParser a) - -> Value - -> Parser (WithJSONWarnings a) -withObjectWarnings expected f = - withObject expected $ - \obj -> - do (a,w) <- runWriterT (f obj) - let unrecognizedFields = - Set.toList - (Set.difference - (Set.fromList (map keyToText (HashMap.keys obj))) - (wpmExpectedFields w)) - return - (WithJSONWarnings a - (wpmWarnings w ++ - case unrecognizedFields of - [] -> [] - _ -> [JSONUnrecognizedFields expected unrecognizedFields])) - --- | Convert a 'WarningParser' to a 'Parser'. -unWarningParser :: WarningParser a -> Parser a -unWarningParser wp = do - (a,_) <- runWriterT wp - return a - --- | Log JSON warnings. -logJSONWarnings - :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) - => FilePath -> [JSONWarning] -> m () -logJSONWarnings fp = - mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) - --- | Handle warnings in a sub-object. -jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a -jsonSubWarnings f = do - WithJSONWarnings result warnings <- f - tell - (mempty - { wpmWarnings = warnings - }) - return result - --- | Handle warnings in a @Traversable@ of sub-objects. -jsonSubWarningsT - :: Traversable t - => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) -jsonSubWarningsT f = - mapM (jsonSubWarnings . return) =<< f - --- | Handle warnings in a @Maybe Traversable@ of sub-objects. -jsonSubWarningsTT - :: (Traversable t, Traversable u) - => WarningParser (u (t (WithJSONWarnings a))) - -> WarningParser (u (t a)) -jsonSubWarningsTT f = - mapM (jsonSubWarningsT . return) =<< f - --- Parsed JSON value without any warnings -noJSONWarnings :: a -> WithJSONWarnings a -noJSONWarnings v = WithJSONWarnings v [] - --- | JSON parser that warns about unexpected fields in objects. -type WarningParser a = WriterT WarningParserMonoid Parser a - --- | Monoid used by 'WarningParser' to track expected fields and warnings. -data WarningParserMonoid = WarningParserMonoid - { wpmExpectedFields :: !(Set Text) - , wpmWarnings :: [JSONWarning] - } deriving Generic -instance Semigroup WarningParserMonoid where - (<>) = mappenddefault -instance Monoid WarningParserMonoid where - mempty = memptydefault - mappend = (<>) -instance IsString WarningParserMonoid where - fromString s = mempty { wpmWarnings = [fromString s] } - --- Parsed JSON value with its warnings -data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] - 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 = (<>) - --- | Warning output from 'WarningParser'. -data JSONWarning = JSONUnrecognizedFields String [Text] - | JSONGeneralWarning !Text - deriving Eq -instance Show JSONWarning where - show = T.unpack . utf8BuilderToText . display -instance Display JSONWarning where - display (JSONUnrecognizedFields obj [field]) = - "Unrecognized field in " <> fromString obj <> ": " <> display field - display (JSONUnrecognizedFields obj fields) = - "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) - display (JSONGeneralWarning t) = display t - -instance IsString JSONWarning where - fromString = JSONGeneralWarning . T.pack - -instance FromJSON (WithJSONWarnings StylesUpdate) where - parseJSON v = noJSONWarnings <$> parseJSON v +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Extensions to Aeson parsing of objects. This module is intended +-- for internal use by Pantry and Stack only. The intention is to +-- fully remove this module in the future. /DO NOT RELY ON IT/. +module Pantry.Internal.AesonExtended ( + module Export + -- * Extended failure messages + , (.:) + , (.:?) + -- * JSON Parser that emits warnings + , JSONWarning (..) + , WarningParser + , WithJSONWarnings (..) + , withObjectWarnings + , jsonSubWarnings + , jsonSubWarningsT + , jsonSubWarningsTT + , logJSONWarnings + , noJSONWarnings + , tellJSONField + , unWarningParser + , (..:) + , (...:) + , (..:?) + , (...:?) + , (..!=) + ) where + +import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) +import Data.Aeson as Export hiding ((.:), (.:?)) +import qualified Data.Aeson as A +import Data.Aeson.Types hiding ((.:), (.:?)) +import qualified Data.Set as Set +import Data.Text (unpack) +import qualified Data.Text as T +import Generics.Deriving.Monoid (mappenddefault, memptydefault) +import RIO +import RIO.PrettyPrint.StylesUpdate (StylesUpdate) + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key +import qualified Data.Aeson.KeyMap as HashMap + +keyToText :: Data.Aeson.Key.Key -> Text +keyToText = Data.Aeson.Key.toText + +textToKey :: Text -> Data.Aeson.Key.Key +textToKey = Data.Aeson.Key.fromText +#else +import qualified Data.HashMap.Strict as HashMap + +keyToText :: Text -> Text +keyToText = id + +textToKey :: Text -> Text +textToKey = id +#endif + +-- | Extends @.:@ warning to include field name. +(.:) :: FromJSON a => Object -> Text -> Parser a +(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: textToKey p) +{-# INLINE (.:) #-} + +-- | Extends @.:?@ warning to include field name. +(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) +(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? textToKey p) +{-# INLINE (.:?) #-} + +-- | 'WarningParser' version of @.:@. +(..:) + :: FromJSON a + => Object -> Text -> WarningParser a +o ..: k = tellJSONField k >> lift (o .: k) + +-- | 'WarningParser' version of @.:?@. +(..:?) + :: FromJSON a + => Object -> Text -> WarningParser (Maybe a) +o ..:? k = tellJSONField k >> lift (o .:? k) + +-- | 'WarningParser' version of @.!=@. +(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a +wp ..!= d = + flip mapWriterT wp $ + \p -> + do a <- fmap snd p + fmap (, a) (fmap fst p .!= d) + +presentCount :: Object -> [Text] -> Int +presentCount o ss = length . filter (\x -> HashMap.member (textToKey x) o) $ ss + +-- | Synonym version of @..:@. +(...:) :: FromJSON a => Object -> [Text] -> WarningParser a +_ ...: [] = fail "failed to find an empty key" +o ...: ss@(key:_) = apply + where pc = presentCount o ss + apply | pc == 0 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "keys " ++ show ss ++ " not present" + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss + +-- | Synonym version of @..:?@. +(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a) +_ ...:? [] = fail "failed to find an empty key" +o ...:? ss@(key:_) = apply + where pc = presentCount o ss + apply | pc == 0 = return Nothing + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss + +-- | Tell warning parser about an expected field, so it doesn't warn about it. +tellJSONField :: Text -> WarningParser () +tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) + +-- | 'WarningParser' version of 'withObject'. +withObjectWarnings :: String + -> (Object -> WarningParser a) + -> Value + -> Parser (WithJSONWarnings a) +withObjectWarnings expected f = + withObject expected $ + \obj -> + do (a,w) <- runWriterT (f obj) + let unrecognizedFields = + Set.toList + (Set.difference + (Set.fromList (map keyToText (HashMap.keys obj))) + (wpmExpectedFields w)) + return + (WithJSONWarnings a + (wpmWarnings w ++ + case unrecognizedFields of + [] -> [] + _ -> [JSONUnrecognizedFields expected unrecognizedFields])) + +-- | Convert a 'WarningParser' to a 'Parser'. +unWarningParser :: WarningParser a -> Parser a +unWarningParser wp = do + (a,_) <- runWriterT wp + return a + +-- | Log JSON warnings. +logJSONWarnings + :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) + => FilePath -> [JSONWarning] -> m () +logJSONWarnings fp = + mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) + +-- | Handle warnings in a sub-object. +jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a +jsonSubWarnings f = do + WithJSONWarnings result warnings <- f + tell + (mempty + { wpmWarnings = warnings + }) + return result + +-- | Handle warnings in a @Traversable@ of sub-objects. +jsonSubWarningsT + :: Traversable t + => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) +jsonSubWarningsT f = + mapM (jsonSubWarnings . return) =<< f + +-- | Handle warnings in a @Maybe Traversable@ of sub-objects. +jsonSubWarningsTT + :: (Traversable t, Traversable u) + => WarningParser (u (t (WithJSONWarnings a))) + -> WarningParser (u (t a)) +jsonSubWarningsTT f = + mapM (jsonSubWarningsT . return) =<< f + +-- Parsed JSON value without any warnings +noJSONWarnings :: a -> WithJSONWarnings a +noJSONWarnings v = WithJSONWarnings v [] + +-- | JSON parser that warns about unexpected fields in objects. +type WarningParser a = WriterT WarningParserMonoid Parser a + +-- | Monoid used by 'WarningParser' to track expected fields and warnings. +data WarningParserMonoid = WarningParserMonoid + { wpmExpectedFields :: !(Set Text) + , wpmWarnings :: [JSONWarning] + } deriving Generic +instance Semigroup WarningParserMonoid where + (<>) = mappenddefault +instance Monoid WarningParserMonoid where + mempty = memptydefault + mappend = (<>) +instance IsString WarningParserMonoid where + fromString s = mempty { wpmWarnings = [fromString s] } + +-- Parsed JSON value with its warnings +data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] + 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 = (<>) + +-- | Warning output from 'WarningParser'. +data JSONWarning = JSONUnrecognizedFields String [Text] + | JSONGeneralWarning !Text + deriving Eq +instance Show JSONWarning where + show = T.unpack . utf8BuilderToText . display +instance Display JSONWarning where + display (JSONUnrecognizedFields obj [field]) = + "Unrecognized field in " <> fromString obj <> ": " <> display field + display (JSONUnrecognizedFields obj fields) = + "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) + display (JSONGeneralWarning t) = display t + +instance IsString JSONWarning where + fromString = JSONGeneralWarning . T.pack + +instance FromJSON (WithJSONWarnings StylesUpdate) where + parseJSON v = noJSONWarnings <$> parseJSON v diff --git a/src/Pantry/Internal/Companion.hs b/src/Pantry/Internal/Companion.hs --- a/src/Pantry/Internal/Companion.hs +++ b/src/Pantry/Internal/Companion.hs @@ -1,78 +1,78 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | Companion threads, such as for printing messages saying we're --- still busy. Ultimately this could be put into its own package. This --- is a non-standard API for use by Pantry and Stack, please /DO NOT --- DEPEND ON IT/. -module Pantry.Internal.Companion - ( withCompanion - , onCompanionDone - , Companion - , Delay - , StopCompanion - ) where - -import RIO - --- | A companion thread which can perform arbitrary actions as well as delay -type Companion m = Delay -> m () - --- | Delay the given number of microseconds. If 'StopCompanion' is --- triggered before the timer completes, a 'CompanionDone' exception --- will be thrown (which is caught internally by 'withCompanion'). -type Delay = forall mio. MonadIO mio => Int -> mio () - --- | Tell the 'Companion' to stop. The next time 'Delay' is --- called, or if a 'Delay' is currently blocking, the 'Companion' thread --- will exit with a 'CompanionDone' exception. -type StopCompanion m = m () - --- | When a delay was interrupted because we're told to stop, perform --- this action. -onCompanionDone - :: MonadUnliftIO m - => m () -- ^ the delay - -> m () -- ^ action to perform - -> m () -onCompanionDone theDelay theAction = - theDelay `withException` \CompanionDone -> theAction - --- | Internal exception used by 'withCompanion' to allow short-circuiting --- of the 'Companion'. Should not be used outside of this module. -data CompanionDone = CompanionDone - deriving (Show, Typeable) -instance Exception CompanionDone - --- | Keep running the 'Companion' action until either the inner action --- completes or calls the 'StopCompanion' action. This can be used to --- give the user status information while running a long running --- operations. -withCompanion - :: forall m a. MonadUnliftIO m - => Companion m - -> (StopCompanion m -> m a) - -> m a -withCompanion companion inner = do - -- Variable to indicate 'Delay'ing should result in a 'CompanionDone' - -- exception. - shouldStopVar <- newTVarIO False - let -- Relatively simple: set shouldStopVar to True - stopCompanion = atomically $ writeTVar shouldStopVar True - - delay :: Delay - delay usec = do - -- Register a delay with the runtime system - delayDoneVar <- registerDelay usec - join $ atomically $ - -- Delay has triggered, keep going - (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> - -- Time to stop the companion, throw a 'CompanionDone' exception immediately - (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) - - -- Run the 'Companion' and inner action together - runConcurrently $ - -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior - Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> - -- Run the inner action, giving it the 'StopCompanion' action, and - -- ensuring it is called regardless of exceptions. - Concurrently (inner stopCompanion `finally` stopCompanion) +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | Companion threads, such as for printing messages saying we're +-- still busy. Ultimately this could be put into its own package. This +-- is a non-standard API for use by Pantry and Stack, please /DO NOT +-- DEPEND ON IT/. +module Pantry.Internal.Companion + ( withCompanion + , onCompanionDone + , Companion + , Delay + , StopCompanion + ) where + +import RIO + +-- | A companion thread which can perform arbitrary actions as well as delay +type Companion m = Delay -> m () + +-- | Delay the given number of microseconds. If 'StopCompanion' is +-- triggered before the timer completes, a 'CompanionDone' exception +-- will be thrown (which is caught internally by 'withCompanion'). +type Delay = forall mio. MonadIO mio => Int -> mio () + +-- | Tell the 'Companion' to stop. The next time 'Delay' is +-- called, or if a 'Delay' is currently blocking, the 'Companion' thread +-- will exit with a 'CompanionDone' exception. +type StopCompanion m = m () + +-- | When a delay was interrupted because we're told to stop, perform +-- this action. +onCompanionDone + :: MonadUnliftIO m + => m () -- ^ the delay + -> m () -- ^ action to perform + -> m () +onCompanionDone theDelay theAction = + theDelay `withException` \CompanionDone -> theAction + +-- | Internal exception used by 'withCompanion' to allow short-circuiting +-- of the 'Companion'. Should not be used outside of this module. +data CompanionDone = CompanionDone + deriving (Show, Typeable) +instance Exception CompanionDone + +-- | Keep running the 'Companion' action until either the inner action +-- completes or calls the 'StopCompanion' action. This can be used to +-- give the user status information while running a long running +-- operations. +withCompanion + :: forall m a. MonadUnliftIO m + => Companion m + -> (StopCompanion m -> m a) + -> m a +withCompanion companion inner = do + -- Variable to indicate 'Delay'ing should result in a 'CompanionDone' + -- exception. + shouldStopVar <- newTVarIO False + let -- Relatively simple: set shouldStopVar to True + stopCompanion = atomically $ writeTVar shouldStopVar True + + delay :: Delay + delay usec = do + -- Register a delay with the runtime system + delayDoneVar <- registerDelay usec + join $ atomically $ + -- Delay has triggered, keep going + (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> + -- Time to stop the companion, throw a 'CompanionDone' exception immediately + (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) + + -- Run the 'Companion' and inner action together + runConcurrently $ + -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior + Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> + -- Run the inner action, giving it the 'StopCompanion' action, and + -- ensuring it is called regardless of exceptions. + Concurrently (inner stopCompanion `finally` stopCompanion) diff --git a/src/Pantry/Internal/Stackage.hs b/src/Pantry/Internal/Stackage.hs --- a/src/Pantry/Internal/Stackage.hs +++ b/src/Pantry/Internal/Stackage.hs @@ -1,50 +1,50 @@ --- | All types and functions exported from this module are for advanced usage --- only. They are needed for stackage-server integration with pantry. -module Pantry.Internal.Stackage - ( module X - ) where - -import Pantry.Hackage as X - ( forceUpdateHackageIndex - , getHackageTarball - , HackageTarballResult(..) - ) -import Pantry.Storage as X - ( BlobId - , EntityField(..) - , HackageCabalId - , ModuleNameId - , PackageName - , PackageNameId - , Tree(..) - , TreeEntryId - , TreeId - , Unique(..) - , Version - , versionVersion - , VersionId - , getBlobKey - , getPackageNameById - , getPackageNameId - , getTreeForKey - , getVersionId - , loadBlobById - , storeBlob - , migrateAll - , Key(unBlobKey) - , allHackageCabalCount - , allBlobsSource - , allBlobsCount - , allHackageCabalRawPackageLocations - ) -import Pantry.Types as X - ( ModuleNameP(..) - , PackageNameP(..) - , PantryConfig(..) - , SafeFilePath - , Storage(..) - , VersionP(..) - , mkSafeFilePath - , packageTreeKey - , unSafeFilePath - ) +-- | All types and functions exported from this module are for advanced usage +-- only. They are needed for stackage-server integration with pantry. +module Pantry.Internal.Stackage + ( module X + ) where + +import Pantry.Hackage as X + ( forceUpdateHackageIndex + , getHackageTarball + , HackageTarballResult(..) + ) +import Pantry.Storage as X + ( BlobId + , EntityField(..) + , HackageCabalId + , ModuleNameId + , PackageName + , PackageNameId + , Tree(..) + , TreeEntryId + , TreeId + , Unique(..) + , Version + , versionVersion + , VersionId + , getBlobKey + , getPackageNameById + , getPackageNameId + , getTreeForKey + , getVersionId + , loadBlobById + , storeBlob + , migrateAll + , Key(unBlobKey) + , allHackageCabalCount + , allBlobsSource + , allBlobsCount + , allHackageCabalRawPackageLocations + ) +import Pantry.Types as X + ( ModuleNameP(..) + , PackageNameP(..) + , PantryConfig(..) + , SafeFilePath + , Storage(..) + , VersionP(..) + , mkSafeFilePath + , packageTreeKey + , unSafeFilePath + ) diff --git a/src/Pantry/Internal/StaticBytes.hs b/src/Pantry/Internal/StaticBytes.hs --- a/src/Pantry/Internal/StaticBytes.hs +++ b/src/Pantry/Internal/StaticBytes.hs @@ -1,237 +1,238 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoImplicitPrelude #-} --- | This is an unstable API, exposed only for testing. Relying on --- this may break your code! Caveat emptor. --- --- This module can (and perhaps should) be separate into its own --- package, it's generally useful. -module Pantry.Internal.StaticBytes - ( Bytes8 - , Bytes16 - , Bytes32 - , Bytes64 - , Bytes128 - , DynamicBytes - , StaticBytes - , StaticBytesException (..) - , toStaticExact - , toStaticPad - , toStaticTruncate - , toStaticPadTruncate - , fromStatic - ) where - -import RIO hiding (words) -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Base as VU -import qualified Data.Vector.Storable as VS -import System.IO.Unsafe (unsafePerformIO) -import Foreign.Ptr -import Foreign.ForeignPtr -import Foreign.Storable -import Data.Bits -import qualified Data.Primitive.ByteArray as BA -import Data.ByteArray - -newtype Bytes8 = Bytes8 Word64 - deriving (Eq, Ord, Generic, NFData, Hashable, Data) -instance Show Bytes8 where - show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) -data Bytes16 = Bytes16 !Bytes8 !Bytes8 - deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) -data Bytes32 = Bytes32 !Bytes16 !Bytes16 - deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) -data Bytes64 = Bytes64 !Bytes32 !Bytes32 - deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) -data Bytes128 = Bytes128 !Bytes64 !Bytes64 - deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) - -data StaticBytesException - = NotEnoughBytes - | TooManyBytes - deriving (Show, Eq, Typeable) -instance Exception StaticBytesException - --- All lengths below are given in bytes - -class DynamicBytes dbytes where - lengthD :: dbytes -> Int - -- | Yeah, it looks terrible to use a list here, but fusion should - -- kick in - withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a - -- | May throw a runtime exception if invariants are violated! - fromWordsD :: Int -> [Word64] -> dbytes - -fromWordsForeign - :: (ForeignPtr a -> Int -> b) - -> Int - -> [Word64] - -> b -fromWordsForeign wrapper len words0 = unsafePerformIO $ do - fptr <- B.mallocByteString len - withForeignPtr fptr $ \ptr -> do - let loop _ [] = return () - loop off (w:ws) = do - pokeElemOff (castPtr ptr) off w - loop (off + 1) ws - loop 0 words0 - return $ wrapper fptr len - -withPeekForeign - :: (ForeignPtr a, Int, Int) - -> ((Int -> IO Word64) -> IO b) - -> IO b -withPeekForeign (fptr, off, len) inner = - withForeignPtr fptr $ \ptr -> do - let f off' - | off' >= len = return 0 - | off' + 8 > len = do - let loop w64 i - | off' + i >= len = return w64 - | otherwise = do - w8 :: Word8 <- peekByteOff ptr (off + off' + i) - let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 - loop w64' (i + 1) - loop 0 0 - | otherwise = peekByteOff ptr (off + off') - inner f - -instance DynamicBytes B.ByteString where - lengthD = B.length - fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) - withPeekD = withPeekForeign . B.toForeignPtr - -instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where - lengthD = VS.length - fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0 - withPeekD = withPeekForeign . VS.unsafeToForeignPtr - -instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where - lengthD = VP.length - fromWordsD len words0 = unsafePerformIO $ do - ba <- BA.newByteArray len - let loop _ [] = - VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba - loop i (w:ws) = do - BA.writeByteArray ba i w - loop (i + 1) ws - loop 0 words0 - withPeekD (VP.Vector off len ba) inner = do - let f off' - | off' >= len = return 0 - | off' + 8 > len = do - let loop w64 i - | off' + i >= len = return w64 - | otherwise = do - let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) - let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 - loop w64' (i + 1) - loop 0 0 - | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) - inner f - -instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where - lengthD = VU.length - fromWordsD len words = VU.V_Word8 (fromWordsD len words) - withPeekD (VU.V_Word8 v) = withPeekD v - -class StaticBytes sbytes where - lengthS :: proxy sbytes -> Int -- use type level literals instead? - -- difference list - toWordsS :: sbytes -> [Word64] -> [Word64] - usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes - -instance StaticBytes Bytes8 where - lengthS _ = 8 - toWordsS (Bytes8 w) = (w:) - usePeekS off f = Bytes8 <$> f off - -instance StaticBytes Bytes16 where - lengthS _ = 16 - toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2 - usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f - -instance StaticBytes Bytes32 where - lengthS _ = 32 - toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2 - usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f - -instance StaticBytes Bytes64 where - lengthS _ = 64 - toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2 - usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f - -instance StaticBytes Bytes128 where - lengthS _ = 128 - toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2 - usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f - -instance ByteArrayAccess Bytes8 where - length _ = 8 - withByteArray = withByteArrayS -instance ByteArrayAccess Bytes16 where - length _ = 16 - withByteArray = withByteArrayS -instance ByteArrayAccess Bytes32 where - length _ = 32 - withByteArray = withByteArrayS -instance ByteArrayAccess Bytes64 where - length _ = 64 - withByteArray = withByteArrayS -instance ByteArrayAccess Bytes128 where - length _ = 128 - withByteArray = withByteArrayS - -withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a -withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) - -toStaticExact - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) - => dbytes - -> Either StaticBytesException sbytes -toStaticExact dbytes = - case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of - LT -> Left NotEnoughBytes - GT -> Left TooManyBytes - EQ -> Right (toStaticPadTruncate dbytes) - -toStaticPad - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) - => dbytes - -> Either StaticBytesException sbytes -toStaticPad dbytes = - case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of - GT -> Left TooManyBytes - _ -> Right (toStaticPadTruncate dbytes) - -toStaticTruncate - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) - => dbytes - -> Either StaticBytesException sbytes -toStaticTruncate dbytes = - case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of - LT -> Left NotEnoughBytes - _ -> Right (toStaticPadTruncate dbytes) - -toStaticPadTruncate - :: (DynamicBytes dbytes, StaticBytes sbytes) - => dbytes - -> sbytes -toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) - -fromStatic - :: forall dbytes sbytes. - (DynamicBytes dbytes, StaticBytes sbytes) - => sbytes - -> dbytes -fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | This is an unstable API, exposed only for testing. Relying on +-- this may break your code! Caveat emptor. +-- +-- This module can (and perhaps should) be separate into its own +-- package, it's generally useful. +module Pantry.Internal.StaticBytes + ( Bytes8 + , Bytes16 + , Bytes32 + , Bytes64 + , Bytes128 + , DynamicBytes + , StaticBytes + , StaticBytesException (..) + , toStaticExact + , toStaticPad + , toStaticTruncate + , toStaticPadTruncate + , fromStatic + ) where + +import RIO hiding (words) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Base as VU +import qualified Data.Vector.Storable as VS +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable +import Data.Bits +import qualified Data.Primitive.ByteArray as BA +import Data.ByteArray + +newtype Bytes8 = Bytes8 Word64 + deriving (Eq, Ord, Generic, NFData, Hashable, Data) +instance Show Bytes8 where + show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) +data Bytes16 = Bytes16 !Bytes8 !Bytes8 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes32 = Bytes32 !Bytes16 !Bytes16 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes64 = Bytes64 !Bytes32 !Bytes32 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes128 = Bytes128 !Bytes64 !Bytes64 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) + +data StaticBytesException + = NotEnoughBytes + | TooManyBytes + deriving (Show, Eq, Typeable) +instance Exception StaticBytesException + +-- All lengths below are given in bytes + +class DynamicBytes dbytes where + lengthD :: dbytes -> Int + -- | Yeah, it looks terrible to use a list here, but fusion should + -- kick in + withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a + -- | May throw a runtime exception if invariants are violated! + fromWordsD :: Int -> [Word64] -> dbytes + +fromWordsForeign + :: (ForeignPtr a -> Int -> b) + -> Int + -> [Word64] + -> b +fromWordsForeign wrapper len words0 = unsafePerformIO $ do + fptr <- B.mallocByteString len + withForeignPtr fptr $ \ptr -> do + let loop _ [] = return () + loop off (w:ws) = do + pokeElemOff (castPtr ptr) off w + loop (off + 1) ws + loop 0 words0 + return $ wrapper fptr len + +withPeekForeign + :: (ForeignPtr a, Int, Int) + -> ((Int -> IO Word64) -> IO b) + -> IO b +withPeekForeign (fptr, off, len) inner = + withForeignPtr fptr $ \ptr -> do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + w8 :: Word8 <- peekByteOff ptr (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = peekByteOff ptr (off + off') + inner f + +instance DynamicBytes B.ByteString where + lengthD = B.length + fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) + withPeekD = withPeekForeign . B.toForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where + lengthD = VS.length + fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0 + withPeekD = withPeekForeign . VS.unsafeToForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where + lengthD = VP.length + fromWordsD len words0 = unsafePerformIO $ do + ba <- BA.newByteArray len + let loop _ [] = + VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba + loop i (w:ws) = do + BA.writeByteArray ba i w + loop (i + 1) ws + loop 0 words0 + withPeekD (VP.Vector off len ba) inner = do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) + inner f + +instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where + lengthD = VU.length + fromWordsD len words = VU.V_Word8 (fromWordsD len words) + withPeekD (VU.V_Word8 v) = withPeekD v + +class StaticBytes sbytes where + lengthS :: proxy sbytes -> Int -- use type level literals instead? + -- difference list + toWordsS :: sbytes -> [Word64] -> [Word64] + usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes + +instance StaticBytes Bytes8 where + lengthS _ = 8 + toWordsS (Bytes8 w) = (w:) + usePeekS off f = Bytes8 <$> f off + +instance StaticBytes Bytes16 where + lengthS _ = 16 + toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f + +instance StaticBytes Bytes32 where + lengthS _ = 32 + toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f + +instance StaticBytes Bytes64 where + lengthS _ = 64 + toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f + +instance StaticBytes Bytes128 where + lengthS _ = 128 + toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f + +instance ByteArrayAccess Bytes8 where + length _ = 8 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes16 where + length _ = 16 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes32 where + length _ = 32 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes64 where + length _ = 64 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes128 where + length _ = 128 + withByteArray = withByteArrayS + +withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a +withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) + +toStaticExact + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticExact dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + GT -> Left TooManyBytes + EQ -> Right (toStaticPadTruncate dbytes) + +toStaticPad + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticPad dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + GT -> Left TooManyBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticTruncate + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticTruncate dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticPadTruncate + :: (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> sbytes +toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) + +fromStatic + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => sbytes + -> dbytes +fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS diff --git a/src/Pantry/Repo.hs b/src/Pantry/Repo.hs --- a/src/Pantry/Repo.hs +++ b/src/Pantry/Repo.hs @@ -1,296 +1,296 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} -module Pantry.Repo - ( fetchReposRaw - , fetchRepos - , getRepo - , getRepoKey - , createRepoArchive - , withRepoArchive - , withRepo - ) where - - -import Pantry.Types -import Pantry.Archive -import Pantry.Storage -import RIO -import Path.IO (resolveFile') -import RIO.FilePath (()) -import RIO.Directory (doesDirectoryExist) -import RIO.ByteString (isInfixOf) -import RIO.ByteString.Lazy (toStrict) -import qualified RIO.Map as Map -import RIO.Process -import Database.Persist (Entity (..)) -import qualified RIO.Text as T -import System.Console.ANSI (hSupportsANSIWithoutEmulation) -import System.IsWindows (osIsWindows) - -data TarType = Gnu | Bsd - -getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType -getTarType = do - (_, stdoutBS, _) <- proc "tar" ["--version"] readProcess - let bs = toStrict stdoutBS - pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd - --- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of 'PackageMetadata'. --- --- @since 0.5.3 -fetchReposRaw - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(Repo, RawPackageMetadata)] - -> RIO env () -fetchReposRaw pairs = do - let repos = toAggregateRepos pairs - logDebug (displayShow repos) - for_ repos getRepos - --- | Fetch the given repositories at once and populate the pantry database. --- --- @since 0.5.3 -fetchRepos - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(Repo, PackageMetadata)] - -> RIO env () -fetchRepos pairs = do - -- TODO be more efficient, group together shared archives - fetchReposRaw $ map (second toRawPM) pairs - -getRepoKey - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Repo - -> RawPackageMetadata - -> RIO env TreeKey -getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization - -getRepo - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Repo - -> RawPackageMetadata - -> RIO env Package -getRepo repo pm = do - withCache $ getRepo' repo pm - where - withCache - :: RIO env Package - -> RIO env Package - withCache inner = do - mtid <- withStorage (loadRepoCache repo) - case mtid of - Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid - Nothing -> do - package <- inner - withStorage $ do - ment <- getTreeForKey $ packageTreeKey package - case ment of - Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) - Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid - pure package - -getRepo' - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Repo - -> RawPackageMetadata - -> RIO env Package -getRepo' repo@Repo{..} rpm = do - withRepoArchive (rToSimpleRepo repo) $ \tarball -> do - abs' <- resolveFile' tarball - getArchivePackage - (RPLIRepo repo rpm) - RawArchive - { raLocation = ALFilePath $ ResolvedPath - { resolvedRelative = RelFilePath $ T.pack tarball - , resolvedAbsolute = abs' - } - , raHash = Nothing - , raSize = Nothing - , raSubdir = repoSubdir - } - rpm - -getRepos - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => AggregateRepo - -> RIO env [Package] -getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = - withCache getRepos' - where - withCache inner = do - pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do - loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case - Just tid -> fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid - Nothing -> pure $ Left (subdir, rpm) - let (missingPkgs, cachedPkgs) = partitionEithers pkgs - newPkgs <- - if null missingPkgs - then pure [] - else do - packages <- inner repo { aRepoSubdirs = missingPkgs } - forM packages $ \(package, subdir) -> do - withStorage $ do - ment <- getTreeForKey $ packageTreeKey package - case ment of - Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) - Just (Entity tid _) -> storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid - pure package - pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) - -getRepos' - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => AggregateRepo - -> RIO env [(Package, Text)] -- ^ [(package, subdir)] -getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do - withRepoArchive (arToSimpleRepo ar) $ \tarball -> do - abs' <- resolveFile' tarball - forM repoSubdirs $ \(subdir, rpm) -> do - (,subdir) <$> getArchivePackage - (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) - RawArchive - { raLocation = ALFilePath $ ResolvedPath - { resolvedRelative = RelFilePath $ T.pack tarball - , resolvedAbsolute = abs' - } - , raHash = Nothing - , raSize = Nothing - , raSubdir = subdir - } - rpm - --- | Fetch a repository and create a (temporary) tar archive from it. Pass the --- path of the generated tarball to the given action. -withRepoArchive - :: forall env a. (HasLogFunc env, HasProcessContext env) - => SimpleRepo - -> (FilePath -> RIO env a) - -> RIO env a -withRepoArchive sr action = - withSystemTempDirectory "with-repo-archive" $ \tmpdirArchive -> do - let tarball = tmpdirArchive "foo.tar" - createRepoArchive sr tarball - action tarball - --- | Run a git command, setting appropriate environment variable settings. See --- . -runGitCommand - :: (HasLogFunc env, HasProcessContext env) - => [String] -- ^ args - -> RIO env () -runGitCommand args = - withModifyEnvVars go $ - void $ proc "git" args readProcess_ - where - go = Map.delete "GIT_DIR" - . Map.delete "GIT_CEILING_DIRECTORIES" - . Map.delete "GIT_WORK_TREE" - . Map.delete "GIT_INDEX_FILE" - . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls - . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" - --- Include submodules files into the archive: use `git submodule --- foreach` to execute `git archive` in each submodule and generate --- tar archive. With bsd tar, the generated archive is extracted to a --- temporary folder and the files in them are added to the tarball --- referenced by the variable tarball in the haskell code. This is --- done in GNU tar with -A option. -archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env () -archiveSubmodules tarball = do - tarType <- getTarType - let forceLocal = - if osIsWindows - then " --force-local " - else mempty - case tarType of - Gnu -> runGitCommand - [ "submodule", "foreach", "--recursive" - , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " - <> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar" - ] - Bsd -> - runGitCommand - [ "submodule" - , "foreach" - , "--recursive" - , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD;" <> - " rm -rf temp; mkdir temp; mv bar.tar temp/; tar " <> - " -C temp -xf temp/bar.tar; " <> - "rm temp/bar.tar; tar " <> - " -C temp -rf " <> - tarball <> - " . ;" - ] - --- | Run an hg command -runHgCommand - :: (HasLogFunc env, HasProcessContext env) - => [String] -- ^ args - -> RIO env () -runHgCommand args = void $ proc "hg" args readProcess_ - --- | Create a tarball containing files from a repository -createRepoArchive :: - forall env. (HasLogFunc env, HasProcessContext env) - => SimpleRepo - -> FilePath -- ^ Output tar archive filename - -> RIO env () -createRepoArchive sr tarball = do - withRepo sr $ - case sRepoType sr of - RepoGit -> do - runGitCommand - ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] - archiveSubmodules tarball - RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] - - --- | Clone the repository and execute the action with the working --- directory set to the repository root. --- --- @since 0.1.0.0 -withRepo - :: forall env a. (HasLogFunc env, HasProcessContext env) - => SimpleRepo - -> RIO env a - -> RIO env a -withRepo sr@SimpleRepo{..} action = - withSystemTempDirectory "with-repo" $ \tmpDir -> do - -- Note we do not immediately change directories into the new temporary directory, - -- but instead wait until we have finished cloning the repo. This is because the - -- repo URL may be a relative path on the local filesystem, and we should interpret - -- it as relative to the current directory, not the temporary directory. - let dir = tmpDir "cloned" - (runCommand, resetArgs, submoduleArgs) = - case sRepoType of - RepoGit -> - ( runGitCommand - , ["reset", "--hard", T.unpack sRepoCommit] - , Just ["submodule", "update", "--init", "--recursive"] - ) - RepoHg -> - ( runHgCommand - , ["update", "-C", T.unpack sRepoCommit] - , Nothing - ) - fixANSIForWindows = - -- On Windows 10, an upstream issue with the `git clone` command means that - -- command clears, but does not then restore, the - -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The - -- folowing hack re-enables the lost ANSI-capability. - when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout - - logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl - runCommand ["clone", T.unpack sRepoUrl, dir] - fixANSIForWindows - created <- doesDirectoryExist dir - unless created $ throwIO $ FailedToCloneRepo sr - - withWorkingDir dir $ do - runCommand resetArgs - traverse_ runCommand submoduleArgs - fixANSIForWindows - action +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +module Pantry.Repo + ( fetchReposRaw + , fetchRepos + , getRepo + , getRepoKey + , createRepoArchive + , withRepoArchive + , withRepo + ) where + + +import Pantry.Types +import Pantry.Archive +import Pantry.Storage +import RIO +import Path.IO (resolveFile') +import RIO.FilePath (()) +import RIO.Directory (doesDirectoryExist) +import RIO.ByteString (isInfixOf) +import RIO.ByteString.Lazy (toStrict) +import qualified RIO.Map as Map +import RIO.Process +import Database.Persist (Entity (..)) +import qualified RIO.Text as T +import System.Console.ANSI (hSupportsANSIWithoutEmulation) +import System.IsWindows (osIsWindows) + +data TarType = Gnu | Bsd + +getTarType :: (HasProcessContext env, HasLogFunc env) => RIO env TarType +getTarType = do + (_, stdoutBS, _) <- proc "tar" ["--version"] readProcess + let bs = toStrict stdoutBS + pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd + +-- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of 'PackageMetadata'. +-- +-- @since 0.5.3 +fetchReposRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Repo, RawPackageMetadata)] + -> RIO env () +fetchReposRaw pairs = do + let repos = toAggregateRepos pairs + logDebug (displayShow repos) + for_ repos getRepos + +-- | Fetch the given repositories at once and populate the pantry database. +-- +-- @since 0.5.3 +fetchRepos + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Repo, PackageMetadata)] + -> RIO env () +fetchRepos pairs = do + -- TODO be more efficient, group together shared archives + fetchReposRaw $ map (second toRawPM) pairs + +getRepoKey + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env TreeKey +getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization + +getRepo + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env Package +getRepo repo pm = do + withCache $ getRepo' repo pm + where + withCache + :: RIO env Package + -> RIO env Package + withCache inner = do + mtid <- withStorage (loadRepoCache repo) + case mtid of + Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid + Nothing -> do + package <- inner + withStorage $ do + ment <- getTreeForKey $ packageTreeKey package + case ment of + Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) + Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid + pure package + +getRepo' + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env Package +getRepo' repo@Repo{..} rpm = do + withRepoArchive (rToSimpleRepo repo) $ \tarball -> do + abs' <- resolveFile' tarball + getArchivePackage + (RPLIRepo repo rpm) + RawArchive + { raLocation = ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ T.pack tarball + , resolvedAbsolute = abs' + } + , raHash = Nothing + , raSize = Nothing + , raSubdir = repoSubdir + } + rpm + +getRepos + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => AggregateRepo + -> RIO env [Package] +getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = + withCache getRepos' + where + withCache inner = do + pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do + loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) >>= \case + Just tid -> fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid + Nothing -> pure $ Left (subdir, rpm) + let (missingPkgs, cachedPkgs) = partitionEithers pkgs + newPkgs <- + if null missingPkgs + then pure [] + else do + packages <- inner repo { aRepoSubdirs = missingPkgs } + forM packages $ \(package, subdir) -> do + withStorage $ do + ment <- getTreeForKey $ packageTreeKey package + case ment of + Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) + Just (Entity tid _) -> storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid + pure package + pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs)) + +getRepos' + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => AggregateRepo + -> RIO env [(Package, Text)] -- ^ [(package, subdir)] +getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do + withRepoArchive (arToSimpleRepo ar) $ \tarball -> do + abs' <- resolveFile' tarball + forM repoSubdirs $ \(subdir, rpm) -> do + (,subdir) <$> getArchivePackage + (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) + RawArchive + { raLocation = ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ T.pack tarball + , resolvedAbsolute = abs' + } + , raHash = Nothing + , raSize = Nothing + , raSubdir = subdir + } + rpm + +-- | Fetch a repository and create a (temporary) tar archive from it. Pass the +-- path of the generated tarball to the given action. +withRepoArchive + :: forall env a. (HasLogFunc env, HasProcessContext env) + => SimpleRepo + -> (FilePath -> RIO env a) + -> RIO env a +withRepoArchive sr action = + withSystemTempDirectory "with-repo-archive" $ \tmpdirArchive -> do + let tarball = tmpdirArchive "foo.tar" + createRepoArchive sr tarball + action tarball + +-- | Run a git command, setting appropriate environment variable settings. See +-- . +runGitCommand + :: (HasLogFunc env, HasProcessContext env) + => [String] -- ^ args + -> RIO env () +runGitCommand args = + withModifyEnvVars go $ + void $ proc "git" args readProcess_ + where + go = Map.delete "GIT_DIR" + . Map.delete "GIT_CEILING_DIRECTORIES" + . Map.delete "GIT_WORK_TREE" + . Map.delete "GIT_INDEX_FILE" + . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls + . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" + +-- Include submodules files into the archive: use `git submodule +-- foreach` to execute `git archive` in each submodule and generate +-- tar archive. With bsd tar, the generated archive is extracted to a +-- temporary folder and the files in them are added to the tarball +-- referenced by the variable tarball in the haskell code. This is +-- done in GNU tar with -A option. +archiveSubmodules :: (HasLogFunc env, HasProcessContext env) => FilePath -> RIO env () +archiveSubmodules tarball = do + tarType <- getTarType + let forceLocal = + if osIsWindows + then " --force-local " + else mempty + case tarType of + Gnu -> runGitCommand + [ "submodule", "foreach", "--recursive" + , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD; " + <> "tar" <> forceLocal <> " -Af " <> tarball <> " bar.tar" + ] + Bsd -> + runGitCommand + [ "submodule" + , "foreach" + , "--recursive" + , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD;" <> + " rm -rf temp; mkdir temp; mv bar.tar temp/; tar " <> + " -C temp -xf temp/bar.tar; " <> + "rm temp/bar.tar; tar " <> + " -C temp -rf " <> + tarball <> + " . ;" + ] + +-- | Run an hg command +runHgCommand + :: (HasLogFunc env, HasProcessContext env) + => [String] -- ^ args + -> RIO env () +runHgCommand args = void $ proc "hg" args readProcess_ + +-- | Create a tarball containing files from a repository +createRepoArchive :: + forall env. (HasLogFunc env, HasProcessContext env) + => SimpleRepo + -> FilePath -- ^ Output tar archive filename + -> RIO env () +createRepoArchive sr tarball = do + withRepo sr $ + case sRepoType sr of + RepoGit -> do + runGitCommand + ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] + archiveSubmodules tarball + RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] + + +-- | Clone the repository and execute the action with the working +-- directory set to the repository root. +-- +-- @since 0.1.0.0 +withRepo + :: forall env a. (HasLogFunc env, HasProcessContext env) + => SimpleRepo + -> RIO env a + -> RIO env a +withRepo sr@SimpleRepo{..} action = + withSystemTempDirectory "with-repo" $ \tmpDir -> do + -- Note we do not immediately change directories into the new temporary directory, + -- but instead wait until we have finished cloning the repo. This is because the + -- repo URL may be a relative path on the local filesystem, and we should interpret + -- it as relative to the current directory, not the temporary directory. + let dir = tmpDir "cloned" + (runCommand, resetArgs, submoduleArgs) = + case sRepoType of + RepoGit -> + ( runGitCommand + , ["reset", "--hard", T.unpack sRepoCommit] + , Just ["submodule", "update", "--init", "--recursive"] + ) + RepoHg -> + ( runHgCommand + , ["update", "-C", T.unpack sRepoCommit] + , Nothing + ) + fixANSIForWindows = + -- On Windows 10, an upstream issue with the `git clone` command means that + -- command clears, but does not then restore, the + -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The + -- following hack re-enables the lost ANSI-capability. + when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout + + logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl + runCommand ["clone", T.unpack sRepoUrl, dir] + fixANSIForWindows + created <- doesDirectoryExist dir + unless created $ throwIO $ FailedToCloneRepo sr + + withWorkingDir dir $ do + runCommand resetArgs + traverse_ runCommand submoduleArgs + fixANSIForWindows + action diff --git a/src/Pantry/SHA256.hs b/src/Pantry/SHA256.hs --- a/src/Pantry/SHA256.hs +++ b/src/Pantry/SHA256.hs @@ -1,185 +1,185 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} --- | Provides a data type ('SHA256') for efficient memory --- representation of a sha-256 hash value, together with helper --- functions for converting to and from that value. This module is --- intended to be imported qualified as @SHA256@. --- --- Some nomenclature: --- --- * Hashing calculates a new hash value from some input. @from@ takes a value that representats an existing hash. --- --- * Raw means a raw binary representation of the hash value, without any hex encoding. --- --- * Text always uses lower case hex encoding --- --- @since 0.1.0.0 -module Pantry.SHA256 - ( -- * Types - SHA256 - , SHA256Exception (..) - -- * Hashing - , hashFile - , hashBytes - , hashLazyBytes - , sinkHash - -- * Convert from a hash representation - , fromHexText - , fromHexBytes - , fromDigest - , fromRaw - -- * Convert to a hash representation - , toHexText - , toHexBytes - , toRaw - ) where - -import RIO -import Data.Aeson -import Database.Persist.Sql -import Pantry.Internal.StaticBytes -import Conduit -import qualified RIO.Text as T - -import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) -import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) -import qualified Data.ByteArray -import qualified Data.ByteArray.Encoding as Mem - --- | A SHA256 hash, stored in a static size for more efficient --- memory representation. --- --- @since 0.1.0.0 -newtype SHA256 = SHA256 Bytes32 - deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) - --- | Exceptions which can occur in this module --- --- @since 0.1.0.0 -data SHA256Exception - = InvalidByteCount !ByteString !StaticBytesException - | InvalidHexBytes !ByteString !Text - deriving (Typeable) - --- | Generate a 'SHA256' value by hashing the contents of a file. --- --- @since 0.1.0.0 -hashFile :: MonadIO m => FilePath -> m SHA256 -hashFile fp = fromDigest <$> Hash.hashFile fp - --- | Generate a 'SHA256' value by hashing a @ByteString@. --- --- @since 0.1.0.0 -hashBytes :: ByteString -> SHA256 -hashBytes = fromDigest . Hash.hash - --- | Generate a 'SHA256' value by hashing a lazy @ByteString@. --- --- @since 0.1.0.0 -hashLazyBytes :: LByteString -> SHA256 -hashLazyBytes = fromDigest . Hash.hashlazy - --- | Generate a 'SHA256' value by hashing the contents of a stream. --- --- @since 0.1.0.0 -sinkHash :: Monad m => ConduitT ByteString o m SHA256 -sinkHash = fromDigest <$> Hash.sinkHash - --- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. --- --- @since 0.1.0.0 -fromHexText :: Text -> Either SHA256Exception SHA256 -fromHexText = fromHexBytes . encodeUtf8 - --- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. --- --- @since 0.1.0.0 -fromHexBytes :: ByteString -> Either SHA256Exception SHA256 -fromHexBytes hexBS = do - mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw - --- | Convert a 'Hash.Digest' into a 'SHA256' --- --- @since 0.1.0.0 -fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 -fromDigest digest = - case toStaticExact (Data.ByteArray.convert digest :: ByteString) of - Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) - Right x -> SHA256 x - --- | Convert a raw representation of a hash into a 'SHA256'. --- --- @since 0.1.0.0 -fromRaw :: ByteString -> Either SHA256Exception SHA256 -fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) - --- | Convert a 'SHA256' into a base16-encoded SHA256 hash. --- --- @since 0.1.0.0 -toHexText :: SHA256 -> Text -toHexText ss = - case decodeUtf8' $ toHexBytes ss of - Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) - Right t -> t - --- | Convert a 'SHA256' into a base16-encoded SHA256 hash. --- --- @since 0.1.0.0 -toHexBytes :: SHA256 -> ByteString -toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x - --- | Convert a 'SHA256' into a raw binary representation. --- --- @since 0.1.0.0 -toRaw :: SHA256 -> ByteString -toRaw (SHA256 x) = Data.ByteArray.convert x - --- Instances - -instance Show SHA256 where - show s = "SHA256 " ++ show (toHexText s) - -instance PersistField SHA256 where - toPersistValue = PersistByteString . toRaw - fromPersistValue (PersistByteString bs) = - case toStaticExact bs of - Left e -> Left $ tshow e - Right ss -> pure $ SHA256 ss - fromPersistValue x = Left $ "Unexpected value: " <> tshow x - -instance PersistFieldSql SHA256 where - sqlType _ = SqlBlob - -instance Display SHA256 where - display = displayBytesUtf8 . toHexBytes - -instance ToJSON SHA256 where - toJSON = toJSON . toHexText -instance FromJSON SHA256 where - parseJSON = withText "SHA256" $ \t -> - case fromHexText t of - Right x -> pure x - Left e -> fail $ concat - [ "Invalid SHA256 " - , show t - , ": " - , show e - ] - -instance Exception SHA256Exception -instance Show SHA256Exception where - show = T.unpack . utf8BuilderToText . display -instance Display SHA256Exception where - display (InvalidByteCount bs sbe) = - "Invalid byte count creating a SHA256 from " <> - displayShow bs <> - ": " <> - displayShow sbe - display (InvalidHexBytes bs t) = - "Invalid hex bytes creating a SHA256: " <> - displayShow bs <> - ": " <> - display t +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Provides a data type ('SHA256') for efficient memory +-- representation of a sha-256 hash value, together with helper +-- functions for converting to and from that value. This module is +-- intended to be imported qualified as @SHA256@. +-- +-- Some nomenclature: +-- +-- * Hashing calculates a new hash value from some input. @from@ takes a value that represents an existing hash. +-- +-- * Raw means a raw binary representation of the hash value, without any hex encoding. +-- +-- * Text always uses lower case hex encoding +-- +-- @since 0.1.0.0 +module Pantry.SHA256 + ( -- * Types + SHA256 + , SHA256Exception (..) + -- * Hashing + , hashFile + , hashBytes + , hashLazyBytes + , sinkHash + -- * Convert from a hash representation + , fromHexText + , fromHexBytes + , fromDigest + , fromRaw + -- * Convert to a hash representation + , toHexText + , toHexBytes + , toRaw + ) where + +import RIO +import Data.Aeson +import Database.Persist.Sql +import Pantry.Internal.StaticBytes +import Conduit +import qualified RIO.Text as T + +import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) +import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) +import qualified Data.ByteArray +import qualified Data.ByteArray.Encoding as Mem + +-- | A SHA256 hash, stored in a static size for more efficient +-- memory representation. +-- +-- @since 0.1.0.0 +newtype SHA256 = SHA256 Bytes32 + deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) + +-- | Exceptions which can occur in this module +-- +-- @since 0.1.0.0 +data SHA256Exception + = InvalidByteCount !ByteString !StaticBytesException + | InvalidHexBytes !ByteString !Text + deriving (Typeable) + +-- | Generate a 'SHA256' value by hashing the contents of a file. +-- +-- @since 0.1.0.0 +hashFile :: MonadIO m => FilePath -> m SHA256 +hashFile fp = fromDigest <$> Hash.hashFile fp + +-- | Generate a 'SHA256' value by hashing a @ByteString@. +-- +-- @since 0.1.0.0 +hashBytes :: ByteString -> SHA256 +hashBytes = fromDigest . Hash.hash + +-- | Generate a 'SHA256' value by hashing a lazy @ByteString@. +-- +-- @since 0.1.0.0 +hashLazyBytes :: LByteString -> SHA256 +hashLazyBytes = fromDigest . Hash.hashlazy + +-- | Generate a 'SHA256' value by hashing the contents of a stream. +-- +-- @since 0.1.0.0 +sinkHash :: Monad m => ConduitT ByteString o m SHA256 +sinkHash = fromDigest <$> Hash.sinkHash + +-- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexText :: Text -> Either SHA256Exception SHA256 +fromHexText = fromHexBytes . encodeUtf8 + +-- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexBytes :: ByteString -> Either SHA256Exception SHA256 +fromHexBytes hexBS = do + mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw + +-- | Convert a 'Hash.Digest' into a 'SHA256' +-- +-- @since 0.1.0.0 +fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 +fromDigest digest = + case toStaticExact (Data.ByteArray.convert digest :: ByteString) of + Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) + Right x -> SHA256 x + +-- | Convert a raw representation of a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromRaw :: ByteString -> Either SHA256Exception SHA256 +fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexText :: SHA256 -> Text +toHexText ss = + case decodeUtf8' $ toHexBytes ss of + Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) + Right t -> t + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexBytes :: SHA256 -> ByteString +toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x + +-- | Convert a 'SHA256' into a raw binary representation. +-- +-- @since 0.1.0.0 +toRaw :: SHA256 -> ByteString +toRaw (SHA256 x) = Data.ByteArray.convert x + +-- Instances + +instance Show SHA256 where + show s = "SHA256 " ++ show (toHexText s) + +instance PersistField SHA256 where + toPersistValue = PersistByteString . toRaw + fromPersistValue (PersistByteString bs) = + case toStaticExact bs of + Left e -> Left $ tshow e + Right ss -> pure $ SHA256 ss + fromPersistValue x = Left $ "Unexpected value: " <> tshow x + +instance PersistFieldSql SHA256 where + sqlType _ = SqlBlob + +instance Display SHA256 where + display = displayBytesUtf8 . toHexBytes + +instance ToJSON SHA256 where + toJSON = toJSON . toHexText +instance FromJSON SHA256 where + parseJSON = withText "SHA256" $ \t -> + case fromHexText t of + Right x -> pure x + Left e -> fail $ concat + [ "Invalid SHA256 " + , show t + , ": " + , show e + ] + +instance Exception SHA256Exception +instance Show SHA256Exception where + show = T.unpack . utf8BuilderToText . display +instance Display SHA256Exception where + display (InvalidByteCount bs sbe) = + "Invalid byte count creating a SHA256 from " <> + displayShow bs <> + ": " <> + displayShow sbe + display (InvalidHexBytes bs t) = + "Invalid hex bytes creating a SHA256: " <> + displayShow bs <> + ": " <> + display t diff --git a/src/Pantry/SQLite.hs b/src/Pantry/SQLite.hs --- a/src/Pantry/SQLite.hs +++ b/src/Pantry/SQLite.hs @@ -1,103 +1,103 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -module Pantry.SQLite - ( Storage (..) - , initStorage - ) where - -import RIO hiding (FilePath) -import Database.Persist.Sqlite -import RIO.Orphans () -import Path (Path, Abs, File, toFilePath, parent) -import Path.IO (ensureDir) -import Pantry.Types (PantryException (MigrationFailure), Storage (..)) -import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) -import Pantry.Internal.Companion - -initStorage - :: HasLogFunc env - => Text - -> Migration - -> Path Abs File -- ^ storage file - -> (Storage -> RIO env a) - -> RIO env a -initStorage description migration fp inner = do - ensureDir $ parent fp - - migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ - withSqliteConnInfo (sqinfo True) $ runSqlConn $ - runMigrationSilent migration - forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig - - -- Make a single connection to the SQLite database and wrap it in an MVar for - -- the entire execution context. Previously we used a resource pool of size - -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird - -- interaction with Docker on OS X where when resource-pool's reaper would - -- trigger, it would somehow cause the Stack process inside the container to - -- die with a SIGBUS. Definitely an interesting thing worth following up - -- on... - withSqliteConnInfo (sqinfo False) $ \conn0 -> do - connVar <- newMVar conn0 - inner $ Storage - -- NOTE: Currently, we take a write lock on every action. This is - -- a bit heavyweight, but it avoids the SQLITE_BUSY errors - -- reported in - -- - -- completely. We can investigate more elegant solutions in the - -- future, such as separate read and write actions or introducing - -- smarter retry logic. - { withStorage_ = \action -> withMVar connVar $ \conn -> - withWriteLock (display description) fp $ - runSqlConn action conn - , withWriteLock_ = id - } - where - wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) - - sqinfo isMigration - = set extraPragmas ["PRAGMA busy_timeout=2000;"] - $ set walEnabled False - - -- When doing a migration, we want to disable foreign key - -- checking, since the order in which tables are created by - -- the migration scripts may not respect foreign keys. The - -- rest of the time: enforce those foreign keys. - $ set fkEnabled (not isMigration) - - $ mkSqliteConnectionInfo (fromString $ toFilePath fp) - --- | Ensure that only one process is trying to write to the database --- at a time. See --- https://github.com/commercialhaskell/stack/issues/4471 and comments --- above. -withWriteLock - :: HasLogFunc env - => Utf8Builder -- ^ database description, for lock messages - -> Path Abs File -- ^ SQLite database file - -> RIO env a - -> RIO env a -withWriteLock desc dbFile inner = do - let lockFile = toFilePath dbFile ++ ".pantry-write-lock" - withRunInIO $ \run -> do - mres <- withTryFileLock lockFile Exclusive $ const $ run inner - case mres of - Just res -> pure res - Nothing -> do - let complainer :: Companion IO - complainer delay = run $ do - -- Wait five seconds before giving the first message to - -- avoid spamming the user for uninteresting file locks - delay $ 5 * 1000 * 1000 -- 5 seconds - logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." - - -- Now loop printing a message every 1 minute - forever $ do - delay (60 * 1000 * 1000) -- 1 minute - `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") - logWarn ("Still waiting on the " <> desc <> " database write lock...") - withCompanion complainer $ \stopComplaining -> - withFileLock lockFile Exclusive $ const $ do - stopComplaining - run inner +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +module Pantry.SQLite + ( Storage (..) + , initStorage + ) where + +import RIO hiding (FilePath) +import Database.Persist.Sqlite +import RIO.Orphans () +import Path (Path, Abs, File, toFilePath, parent) +import Path.IO (ensureDir) +import Pantry.Types (PantryException (MigrationFailure), Storage (..)) +import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) +import Pantry.Internal.Companion + +initStorage + :: HasLogFunc env + => Text + -> Migration + -> Path Abs File -- ^ storage file + -> (Storage -> RIO env a) + -> RIO env a +initStorage description migration fp inner = do + ensureDir $ parent fp + + migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ + withSqliteConnInfo (sqinfo True) $ runSqlConn $ + runMigrationSilent migration + forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig + + -- Make a single connection to the SQLite database and wrap it in an MVar for + -- the entire execution context. Previously we used a resource pool of size + -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird + -- interaction with Docker on OS X where when resource-pool's reaper would + -- trigger, it would somehow cause the Stack process inside the container to + -- die with a SIGBUS. Definitely an interesting thing worth following up + -- on... + withSqliteConnInfo (sqinfo False) $ \conn0 -> do + connVar <- newMVar conn0 + inner $ Storage + -- NOTE: Currently, we take a write lock on every action. This is + -- a bit heavyweight, but it avoids the SQLITE_BUSY errors + -- reported in + -- + -- completely. We can investigate more elegant solutions in the + -- future, such as separate read and write actions or introducing + -- smarter retry logic. + { withStorage_ = \action -> withMVar connVar $ \conn -> + withWriteLock (display description) fp $ + runSqlConn action conn + , withWriteLock_ = id + } + where + wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) + + sqinfo isMigration + = set extraPragmas ["PRAGMA busy_timeout=2000;"] + $ set walEnabled False + + -- When doing a migration, we want to disable foreign key + -- checking, since the order in which tables are created by + -- the migration scripts may not respect foreign keys. The + -- rest of the time: enforce those foreign keys. + $ set fkEnabled (not isMigration) + + $ mkSqliteConnectionInfo (fromString $ toFilePath fp) + +-- | Ensure that only one process is trying to write to the database +-- at a time. See +-- https://github.com/commercialhaskell/stack/issues/4471 and comments +-- above. +withWriteLock + :: HasLogFunc env + => Utf8Builder -- ^ database description, for lock messages + -> Path Abs File -- ^ SQLite database file + -> RIO env a + -> RIO env a +withWriteLock desc dbFile inner = do + let lockFile = toFilePath dbFile ++ ".pantry-write-lock" + withRunInIO $ \run -> do + mres <- withTryFileLock lockFile Exclusive $ const $ run inner + case mres of + Just res -> pure res + Nothing -> do + let complainer :: Companion IO + complainer delay = run $ do + -- Wait five seconds before giving the first message to + -- avoid spamming the user for uninteresting file locks + delay $ 5 * 1000 * 1000 -- 5 seconds + logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." + + -- Now loop printing a message every 1 minute + forever $ do + delay (60 * 1000 * 1000) -- 1 minute + `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") + logWarn ("Still waiting on the " <> desc <> " database write lock...") + withCompanion complainer $ \stopComplaining -> + withFileLock lockFile Exclusive $ const $ do + stopComplaining + run inner diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs --- a/src/Pantry/Storage.hs +++ b/src/Pantry/Storage.hs @@ -1,1205 +1,1206 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -module Pantry.Storage - ( SqlBackend - , initStorage - , withStorage - , migrateAll - , storeBlob - , loadBlob - , loadBlobById - , loadBlobBySHA - , allBlobsSource - , allHackageCabalRawPackageLocations - , allBlobsCount - , allHackageCabalCount - , getBlobKey - , loadURLBlob - , storeURLBlob - , clearHackageRevisions - , storeHackageRevision - , loadHackagePackageVersions - , loadHackagePackageVersion - , loadLatestCacheUpdate - , storeCacheUpdate - , storeHackageTarballInfo - , loadHackageTarballInfo - , getHPackBlobKeyById - , storeTree - , loadTree - , storeHPack - , loadPackageById - , getPackageNameById - , getPackageNameId - , getVersionId - , getTreeForKey - , storeHackageTree - , loadHackageTree - , loadHackageTreeKey - , storeArchiveCache - , loadArchiveCache - , storeRepoCache - , loadRepoCache - , storePreferredVersion - , loadPreferredVersion - , sinkHackagePackageNames - , loadCabalBlobKey - , hpackToCabal - , countHackageCabals - , getSnapshotCacheByHash - , getSnapshotCacheId - , storeSnapshotModuleCache - , loadExposedModulePackages - , findOrGenerateCabalFile - , PackageNameId - , PackageName - , VersionId - , ModuleNameId - , Version - , versionVersion - , Unique(..) - , EntityField(..) - -- avoid warnings - , BlobId - , Key(unBlobKey) - , HackageCabalId - , HackageCabal(..) - , HackageTarballId - , CacheUpdateId - , FilePathId - , Tree(..) - , TreeId - , TreeEntry(..) - , TreeEntryId - , ArchiveCacheId - , RepoCacheId - , PreferredVersionsId - , UrlBlobId - , SnapshotCacheId - , PackageExposedModuleId - , loadCachedTree - , CachedTree (..) - , unCachedTree - ) where - -import RIO hiding (FilePath) -import RIO.Process -import qualified RIO.ByteString as B -import qualified Pantry.Types as P -import qualified RIO.List as List -import qualified RIO.FilePath as FilePath -import RIO.FilePath ((), takeDirectory) -import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) -import Database.Persist -import Database.Persist.Sqlite -import Database.Persist.TH -import RIO.Orphans (HasResourceMap) -import qualified Pantry.SHA256 as SHA256 -import qualified RIO.Map as Map -import qualified RIO.Text as T -import RIO.Time (UTCTime, getCurrentTime) -import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) -import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) -import Pantry.HPack (hpackVersion, hpack) -import Conduit -import Data.Acquire (with) -import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..), connRDBMS) -import qualified Pantry.SQLite as SQLite - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| --- Raw blobs -Blob - sha SHA256 - size FileSize - contents ByteString - UniqueBlobSha sha --- Previously downloaded blobs from given URLs. --- May change over time, so we keep a time column too. -UrlBlob sql=url_blob - url Text - blob BlobId - time UTCTime - UniqueUrlTime url time - --- For normalization, and avoiding storing strings in a bunch of --- tables. -PackageName - name P.PackageNameP - UniquePackageName name -Version - version P.VersionP - UniqueVersion version -FilePath - path P.SafeFilePath - UniqueSfp path - --- Secure download information for a package on Hackage. This does not --- contain revision information, since sdist tarballs are (blessedly) --- unmodified on Hackage. -HackageTarball - name PackageNameId - version VersionId - sha SHA256 - size FileSize - UniqueHackageTarball name version - --- An individual cabal file from Hackage, representing a specific --- revision. -HackageCabal - name PackageNameId - version VersionId - revision P.Revision - cabal BlobId - - -- If available: the full tree containing the HackageTarball - -- contents with the cabal file modified. - tree TreeId Maybe - UniqueHackage name version revision - --- Any preferred-version information from Hackage -PreferredVersions - name PackageNameId - preferred Text - UniquePreferred name - --- Last time we downloaded a 01-index.tar file from Hackage and --- updated the three previous tables. -CacheUpdate - -- When did we do the update? - time UTCTime - - -- How big was the file when we updated, ignoring the last two - -- all-null 512-byte blocks. - size FileSize - - -- SHA256 of the first 'size' bytes of the file - sha SHA256 - --- A tree containing a Haskell package. See associated TreeEntry --- table. -Tree - key BlobId - - -- If the treeCabal field is Nothing, it means the Haskell package - -- doesn't have a corresponding cabal file for it. This may be the case - -- for haskell package referenced by git repository with only a hpack file. - cabal BlobId Maybe - cabalType FileType - name PackageNameId - version VersionId - UniqueTree key - -HPack - tree TreeId - - -- hpack version used for generating this cabal file - version VersionId - - -- Generated cabal file for the given tree and hpack version - cabalBlob BlobId - cabalPath FilePathId - - UniqueHPack tree version - --- An individual file within a Tree. -TreeEntry - tree TreeId - path FilePathId - blob BlobId - type FileType - --- Like UrlBlob, but stores the contents as a Tree. -ArchiveCache - time UTCTime - url Text - subdir Text - sha SHA256 - size FileSize - tree TreeId - --- Like ArchiveCache, but for a Repo. -RepoCache - time UTCTime - url Text - type P.RepoType - commit Text - subdir Text - tree TreeId - --- Identified by sha of all immutable packages contained in a snapshot --- and GHC version used -SnapshotCache - sha SHA256 - UniqueSnapshotCache sha - -PackageExposedModule - snapshotCache SnapshotCacheId - module ModuleNameId - package PackageNameId - -ModuleName - name P.ModuleNameP - UniqueModule name -|] - -initStorage - :: HasLogFunc env - => Path Abs File -- ^ storage file - -> (P.Storage -> RIO env a) - -> RIO env a -initStorage = - SQLite.initStorage "Pantry" migrateAll - -withStorage - :: (HasPantryConfig env, HasLogFunc env) - => ReaderT SqlBackend (RIO env) a - -> RIO env a -withStorage action = do - storage <- view (P.pantryConfigL.to P.pcStorage) - SQLite.withStorage_ storage action - --- | This is a helper type to distinguish db queries between different rdbms backends. The important --- part is that the affects described in this data type should be semantically equivalent between --- the supported engines. -data RdbmsActions env a = RdbmsActions - { raSqlite :: !(ReaderT SqlBackend (RIO env) a) - -- ^ A query that is specific to SQLite - , raPostgres :: !(ReaderT SqlBackend (RIO env) a) - -- ^ A query that is specific to PostgreSQL - } - --- | This function provides a way to create queries supported by multiple sql backends. -rdbmsAwareQuery - :: RdbmsActions env a - -> ReaderT SqlBackend (RIO env) a -rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do - rdbms <- Pantry.Types.connRDBMS <$> ask - case rdbms of - "postgresql" -> raPostgres - "sqlite" -> raSqlite - _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" - - -getPackageNameById - :: PackageNameId - -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) -getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get - - -getPackageNameId - :: P.PackageName - -> ReaderT SqlBackend (RIO env) PackageNameId -getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP - -getVersionId - :: P.Version - -> ReaderT SqlBackend (RIO env) VersionId -getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP - -storeBlob - :: ByteString - -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) -storeBlob bs = do - let sha = SHA256.hashBytes bs - size = FileSize $ fromIntegral $ B.length bs - keys <- selectKeysList [BlobSha ==. sha] [] - key <- - case keys of - [] -> - rdbmsAwareQuery - RdbmsActions - { raSqlite = - insert Blob {blobSha = sha, blobSize = size, blobContents = bs} - , raPostgres = - do rawExecute - "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" - [ toPersistValue sha - , toPersistValue size - , toPersistValue bs - ] - rawSql - "SELECT blob.id FROM blob WHERE blob.sha = ?" - [toPersistValue sha] >>= \case - [Single key] -> pure key - _ -> - error - "soreBlob: there was a critical problem storing a blob." - } - key:rest -> assert (null rest) (pure key) - pure (key, P.BlobKey sha size) - -loadBlob :: - HasLogFunc env - => BlobKey - -> ReaderT SqlBackend (RIO env) (Maybe ByteString) -loadBlob (P.BlobKey sha size) = do - ment <- getBy $ UniqueBlobSha sha - case ment of - Nothing -> pure Nothing - Just (Entity _ bt) - | blobSize bt == size -> pure $ Just $ blobContents bt - | otherwise -> - Nothing <$ lift (logWarn $ - "Mismatched blob size detected for SHA " <> display sha <> - ". Expected size: " <> display size <> - ". Actual size: " <> display (blobSize bt)) - -loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) -loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] - -loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString -loadBlobById bid = do - mbt <- get bid - case mbt of - Nothing -> error "loadBlobById: ID doesn't exist in database" - Just bt -> pure $ blobContents bt - -allBlobsSource :: - HasResourceMap env - => Maybe BlobId - -- ^ For some x, yield blob whose id>x. - -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () -allBlobsSource mblobId = - selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| - mapC ((entityKey &&& blobContents . entityVal)) - --- | Pull all hackage cabal entries from the database as --- 'RawPackageLocationImmutable'. We do a manual join rather than --- dropping to raw SQL, and Esqueleto would add more deps. -allHackageCabalRawPackageLocations :: - HasResourceMap env - => Maybe HackageCabalId - -- ^ For some x, yield cabals whose id>x. - -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) -allHackageCabalRawPackageLocations mhackageId = do - hackageCabals :: Map HackageCabalId HackageCabal <- - selectTuples - [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]] - [] - packageNames :: Map PackageNameId PackageName <- selectTuples [] [] - versions :: Map VersionId Version <- selectTuples [] [] - for - hackageCabals - (\hackageCabal -> - case Map.lookup (hackageCabalName hackageCabal) packageNames of - Nothing -> error "no such package name" - Just packageName -> - let P.PackageNameP packageName' = packageNameName packageName - in case Map.lookup (hackageCabalVersion hackageCabal) versions of - Nothing -> error "no such version" - Just version -> - let P.VersionP version' = versionVersion version - in do mtree <- - case hackageCabalTree hackageCabal of - Just key -> selectFirst [TreeId ==. key] [] - Nothing -> pure Nothing - mblobKey <- - maybe - (pure Nothing) - (fmap Just . getBlobKey) - (fmap (treeKey . entityVal) mtree) - pure - (P.RPLIHackage - (P.PackageIdentifierRevision - packageName' - version' - (P.CFIRevision - (hackageCabalRevision hackageCabal))) - (fmap P.TreeKey mblobKey))) - where - selectTuples pred sort = - fmap (Map.fromList . map tuple) (selectList pred sort) - tuple (Entity k v) = (k, v) - -allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int -allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] - -allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int -allHackageCabalCount mhackageCabalId = - count - [ HackageCabalId >. hackageCabalId - | Just hackageCabalId <- [mhackageCabalId] - ] - -getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey -getBlobKey bid = do - res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] - case res of - [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid - [(Single sha, Single size)] -> pure $ P.BlobKey sha size - _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) - -getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) -getBlobId (P.BlobKey sha size) = do - res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" - [toPersistValue sha, toPersistValue size] - pure $ listToMaybe $ map unSingle res - -loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) -loadURLBlob url = do - ment <- rawSql - "SELECT blob.contents\n\ - \FROM blob, url_blob\n\ - \WHERE url=?\ - \ AND url_blob.blob=blob.id\n\ - \ ORDER BY url_blob.time DESC" - [toPersistValue url] - case ment of - [] -> pure Nothing - (Single bs) : _ -> pure $ Just bs - -storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () -storeURLBlob url blob = do - (blobId, _) <- storeBlob blob - now <- getCurrentTime - insert_ UrlBlob - { urlBlobUrl = url - , urlBlobBlob = blobId - , urlBlobTime = now - } - -clearHackageRevisions :: ReaderT SqlBackend (RIO env) () -clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) - -storeHackageRevision :: - P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () -storeHackageRevision name version key = do - nameid <- getPackageNameId name - versionid <- getVersionId version - rev <- count - [ HackageCabalName ==. nameid - , HackageCabalVersion ==. versionid - ] - insert_ HackageCabal - { hackageCabalName = nameid - , hackageCabalVersion = versionid - , hackageCabalRevision = Revision (fromIntegral rev) - , hackageCabalCabal = key - , hackageCabalTree = Nothing - } - -loadHackagePackageVersions - :: P.PackageName - -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) -loadHackagePackageVersions name = do - nameid <- getPackageNameId name - -- would be better with esequeleto - (Map.fromListWith Map.union . map go) <$> rawSql - "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ - \FROM hackage_cabal as hackage, version, blob\n\ - \WHERE hackage.name=?\n\ - \AND hackage.version=version.id\n\ - \AND hackage.cabal=blob.id" - [toPersistValue nameid] - where - go (Single revision, Single (P.VersionP version), Single key, Single size) = - (version, Map.singleton revision (P.BlobKey key size)) - -loadHackagePackageVersion - :: P.PackageName - -> P.Version - -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) -loadHackagePackageVersion name version = do - nameid <- getPackageNameId name - versionid <- getVersionId version - -- would be better with esequeleto - (Map.fromList . map go) <$> rawSql - "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ - \FROM hackage_cabal as hackage, version, blob\n\ - \WHERE hackage.name=?\n\ - \AND hackage.version=?\n\ - \AND hackage.cabal=blob.id" - [toPersistValue nameid, toPersistValue versionid] - where - go (Single revision, Single sha, Single size, Single bid) = - (revision, (bid, P.BlobKey sha size)) - -loadLatestCacheUpdate - :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) -loadLatestCacheUpdate = - fmap go <$> selectFirst [] [Desc CacheUpdateTime] - where - go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) - -storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () -storeCacheUpdate size sha = do - now <- getCurrentTime - insert_ CacheUpdate - { cacheUpdateTime = now - , cacheUpdateSize = size - , cacheUpdateSha = sha - } - -storeHackageTarballInfo - :: P.PackageName - -> P.Version - -> SHA256 - -> FileSize - -> ReaderT SqlBackend (RIO env) () -storeHackageTarballInfo name version sha size = do - nameid <- getPackageNameId name - versionid <- getVersionId version - void $ insertBy HackageTarball - { hackageTarballName = nameid - , hackageTarballVersion = versionid - , hackageTarballSha = sha - , hackageTarballSize = size - } - -loadHackageTarballInfo - :: P.PackageName - -> P.Version - -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) -loadHackageTarballInfo name version = do - nameid <- getPackageNameId name - versionid <- getVersionId version - fmap go <$> getBy (UniqueHackageTarball nameid versionid) - where - go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) - -storeCabalFile :: - ByteString - -> P.PackageName - -> ReaderT SqlBackend (RIO env) BlobId -storeCabalFile cabalBS pkgName = do - (bid, _) <- storeBlob cabalBS - let cabalFile = P.cabalFileName pkgName - _ <- insertBy FilePath {filePathPath = cabalFile} - return bid - -loadFilePath :: - SafeFilePath - -> ReaderT SqlBackend (RIO env) (Entity FilePath) -loadFilePath path = do - fp <- getBy $ UniqueSfp path - case fp of - Nothing -> - error $ - "loadFilePath: No row found for " <> - (T.unpack $ P.unSafeFilePath path) - Just record -> return record - -loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) -loadHPackTreeEntity tid = do - filepath <- loadFilePath P.hpackSafeFilePath - let filePathId :: FilePathId = entityKey filepath - hpackTreeEntry <- - selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] - case hpackTreeEntry of - Nothing -> - error $ - "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ - show tid - Just record -> return record - -storeHPack :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable - -> TreeId - -> ReaderT SqlBackend (RIO env) (Key HPack) -storeHPack rpli tid = do - vid <- hpackVersionId - hpackRecord <- getBy (UniqueHPack tid vid) - case hpackRecord of - Nothing -> generateHPack rpli tid vid - Just record -> return $ entityKey record - -loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey -loadCabalBlobKey hpackId = do - hpackRecord <- getJust hpackId - getBlobKey $ hPackCabalBlob hpackRecord - -generateHPack :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> TreeId - -> VersionId - -> ReaderT SqlBackend (RIO env) (Key HPack) -generateHPack rpli tid vid = do - tree <- getTree tid - (pkgName, cabalBS) <- hpackToCabalS rpli tree - bid <- storeCabalFile cabalBS pkgName - let cabalFile = P.cabalFileName pkgName - fid <- insertBy FilePath {filePathPath = cabalFile} - let hpackRecord = - HPack - { hPackTree = tid - , hPackVersion = vid - , hPackCabalBlob = bid - , hPackCabalPath = either entityKey id fid - } - either entityKey id <$> insertBy hpackRecord - - -hpackVersionId :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => ReaderT SqlBackend (RIO env) VersionId -hpackVersionId = do - hpackSoftwareVersion <- lift hpackVersion - fmap (either entityKey id) $ - insertBy $ - Version {versionVersion = P.VersionP hpackSoftwareVersion} - - -getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId -getFilePathId sfp = - selectKeysList [FilePathPath ==. sfp] [] >>= \case - [fpId] -> pure fpId - [] -> - rdbmsAwareQuery - RdbmsActions - { raSqlite = insert $ FilePath sfp - , raPostgres = - do rawExecute - "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" - [toPersistValue sfp] - rawSql - "SELECT id FROM file_path WHERE path = ?" - [toPersistValue sfp] >>= \case - [Single key] -> pure key - _ -> - error - "getFilePathId: there was a critical problem storing a blob." - } - _ -> - error $ - "getFilePathId: FilePath unique constraint key is violated for: " ++ fp - where - fp = T.unpack (P.unSafeFilePath sfp) - --- | A tree that has already been stored in the database -newtype CachedTree - = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId)) - deriving Show - -unCachedTree :: CachedTree -> P.Tree -unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m - -storeTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.PackageIdentifier - -> CachedTree - -> P.BuildFile - -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) -storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do - (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree - (cabalid, ftype) <- case buildFile of - P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) - P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do - buildTypeid <- loadBlobBySHA btypeSha - buildid <- - case buildTypeid of - Just buildId -> pure buildId - Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) - return (Just buildid, ftype) - nameid <- getPackageNameId name - versionid <- getVersionId version - etid <- insertBy Tree - { treeKey = bid - , treeCabal = cabalid - , treeCabalType = ftype - , treeName = nameid - , treeVersion = versionid - } - - (tid, pTreeKey) <- case etid of - Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches - Right tid -> do - for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do - sfpid <- getFilePathId sfp - insert_ TreeEntry - { treeEntryTree = tid - , treeEntryPath = sfpid - , treeEntryBlob = bid' - , treeEntryType = ft - } - pure (tid, P.TreeKey blobKey) - case buildFile of - P.BFHpack _ -> storeHPack rpli tid >> return () - P.BFCabal _ _ -> return () - return (tid, pTreeKey) - -getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree -getTree tid = do - (mts :: Maybe Tree) <- get tid - ts <- - case mts of - Nothing -> - error $ "getTree: invalid foreign key " ++ show tid - Just ts -> pure ts - loadTreeByEnt $ Entity tid ts - -loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) -loadTree key = do - ment <- getTreeForKey key - case ment of - Nothing -> pure Nothing - Just ent -> Just <$> loadTreeByEnt ent - -getTreeForKey - :: TreeKey - -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) -getTreeForKey (P.TreeKey key) = do - mbid <- getBlobId key - case mbid of - Nothing -> pure Nothing - Just bid -> getBy $ UniqueTree bid - -loadPackageById :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> TreeId - -> ReaderT SqlBackend (RIO env) Package -loadPackageById rpli tid = do - (mts :: Maybe Tree) <- get tid - ts <- - case mts of - Nothing -> - error $ "loadPackageById: invalid foreign key " ++ show tid - Just ts -> pure ts - (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts - (blobKey :: BlobKey) <- getBlobKey $ treeKey ts - (mname :: Maybe PackageName) <- get $ treeName ts - name <- - case mname of - Nothing -> - error $ - "loadPackageByid: invalid foreign key " ++ show (treeName ts) - Just (PackageName (P.PackageNameP name)) -> pure name - mversion <- get $ treeVersion ts - version <- - case mversion of - Nothing -> - error $ - "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) - Just (Version (P.VersionP version)) -> pure version - let ident = P.PackageIdentifier name version - (packageEntry, mtree) <- - case treeCabal ts of - Just keyBlob -> do - cabalKey <- getBlobKey keyBlob - return - ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) - , tree) - Nothing -> do - hpackVid <- hpackVersionId - hpackEntity <- getBy (UniqueHPack tid hpackVid) - let (P.TreeMap tmap) = tree - cabalFile = P.cabalFileName name - case hpackEntity of - Nothing - -- This case will happen when you either - -- update stack with a new hpack version or - -- use different hpack version via - -- --with-hpack option. - -> do - (hpackId :: HPackId) <- storeHPack rpli tid - hpackRecord <- getJust hpackId - getHPackCabalFile hpackRecord ts tmap cabalFile - Just (Entity _ item) -> - getHPackCabalFile item ts tmap cabalFile - pure - Package - { packageTreeKey = P.TreeKey blobKey - , packageTree = mtree - , packageCabalEntry = packageEntry - , packageIdent = ident - } - -getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey -getHPackBlobKey hpackRecord = do - let treeId = hPackTree hpackRecord - hpackEntity <- loadHPackTreeEntity treeId - getBlobKey (treeEntryBlob $ entityVal hpackEntity) - -getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey -getHPackBlobKeyById hpackId = do - hpackRecord <- getJust hpackId - getHPackBlobKey hpackRecord - - -getHPackCabalFile :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => HPack - -> Tree - -> Map SafeFilePath P.TreeEntry - -> SafeFilePath - -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) -getHPackCabalFile hpackRecord ts tmap cabalFile = do - cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) - hpackKey <- getHPackBlobKey hpackRecord - hpackSoftwareVersion <- lift hpackVersion - let fileType = treeCabalType ts - cbTreeEntry = P.TreeEntry cabalKey fileType - hpackTreeEntry = P.TreeEntry hpackKey fileType - tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap - return - ( P.PCHpack $ - P.PHpack - { P.phOriginal = hpackTreeEntry - , P.phGenerated = cbTreeEntry - , P.phVersion = hpackSoftwareVersion - } - , tree) - -loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree -loadTreeByEnt (Entity tid _t) = do - entries <- rawSql - "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ - \FROM tree_entry, blob, file_path\n\ - \WHERE tree_entry.tree=?\n\ - \AND tree_entry.blob=blob.id\n\ - \AND tree_entry.path=file_path.id" - [toPersistValue tid] - pure $ P.TreeMap $ Map.fromList $ map - (\(Single sfp, Single sha, Single size, Single ft) -> - (sfp, P.TreeEntry (P.BlobKey sha size) ft)) - entries - -storeHackageTree - :: P.PackageName - -> P.Version - -> BlobId - -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () -storeHackageTree name version cabal treeKey' = do - nameid <- getPackageNameId name - versionid <- getVersionId version - ment <- getTreeForKey treeKey' - for_ ment $ \ent -> updateWhere - [ HackageCabalName ==. nameid - , HackageCabalVersion ==. versionid - , HackageCabalCabal ==. cabal - ] - [HackageCabalTree =. Just (entityKey ent)] - -loadHackageTreeKey - :: P.PackageName - -> P.Version - -> SHA256 - -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) -loadHackageTreeKey name ver sha = do - res <- rawSql - "SELECT treeblob.sha, treeblob.size\n\ - \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ - \WHERE package_name.name=?\n\ - \AND version.version=?\n\ - \AND cabalblob.sha=?\n\ - \AND hackage_cabal.name=package_name.id\n\ - \AND hackage_cabal.version=version.id\n\ - \AND hackage_cabal.cabal=cabalblob.id\n\ - \AND hackage_cabal.tree=tree.id\n\ - \AND tree.key=treeblob.id" - [ toPersistValue $ P.PackageNameP name - , toPersistValue $ P.VersionP ver - , toPersistValue sha - ] - case res of - [] -> pure Nothing - (Single treesha, Single size):_ -> - pure $ Just $ P.TreeKey $ P.BlobKey treesha size - -loadHackageTree - :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.PackageName - -> P.Version - -> BlobId - -> ReaderT SqlBackend (RIO env) (Maybe Package) -loadHackageTree rpli name ver bid = do - nameid <- getPackageNameId name - versionid <- getVersionId ver - ment <- selectFirst - [ HackageCabalName ==. nameid - , HackageCabalVersion ==. versionid - , HackageCabalCabal ==. bid - , HackageCabalTree !=. Nothing - ] - [] - case ment of - Nothing -> pure Nothing - Just (Entity _ hc) -> - case hackageCabalTree hc of - Nothing -> assert False $ pure Nothing - Just tid -> Just <$> loadPackageById rpli tid - -storeArchiveCache - :: Text -- ^ URL - -> Text -- ^ subdir - -> SHA256 - -> FileSize - -> P.TreeKey - -> ReaderT SqlBackend (RIO env) () -storeArchiveCache url subdir sha size treeKey' = do - now <- getCurrentTime - ment <- getTreeForKey treeKey' - for_ ment $ \ent -> insert_ ArchiveCache - { archiveCacheTime = now - , archiveCacheUrl = url - , archiveCacheSubdir = subdir - , archiveCacheSha = sha - , archiveCacheSize = size - , archiveCacheTree = entityKey ent - } - -loadArchiveCache - :: Text -- ^ URL - -> Text -- ^ subdir - -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] -loadArchiveCache url subdir = map go <$> selectList - [ ArchiveCacheUrl ==. url - , ArchiveCacheSubdir ==. subdir - ] - [Desc ArchiveCacheTime] - where - go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) - -storeRepoCache - :: Repo - -> Text -- ^ subdir - -> TreeId - -> ReaderT SqlBackend (RIO env) () -storeRepoCache repo subdir tid = do - now <- getCurrentTime - insert_ RepoCache - { repoCacheTime = now - , repoCacheUrl = repoUrl repo - , repoCacheType = repoType repo - , repoCacheCommit = repoCommit repo - , repoCacheSubdir = subdir - , repoCacheTree = tid - } - -loadRepoCache - :: Repo - -> ReaderT SqlBackend (RIO env) (Maybe TreeId) -loadRepoCache repo = fmap (repoCacheTree . entityVal) <$> selectFirst - [ RepoCacheUrl ==. repoUrl repo - , RepoCacheType ==. repoType repo - , RepoCacheCommit ==. repoCommit repo - , RepoCacheSubdir ==. repoSubdir repo - ] - [Desc RepoCacheTime] - -storePreferredVersion :: - P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () -storePreferredVersion name p = do - nameid <- getPackageNameId name - ment <- getBy $ UniquePreferred nameid - case ment of - Nothing -> insert_ PreferredVersions - { preferredVersionsName = nameid - , preferredVersionsPreferred = p - } - Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] - -loadPreferredVersion :: - P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) -loadPreferredVersion name = do - nameid <- getPackageNameId name - fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) - -sinkHackagePackageNames - :: (P.PackageName -> Bool) - -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a - -> ReaderT SqlBackend (RIO env) a -sinkHackagePackageNames predicate sink = do - acqSrc <- selectSourceRes [] [] - with acqSrc $ \src -> runConduit - $ src - .| concatMapMC go - .| sink - where - go (Entity nameid (PackageName (PackageNameP name))) - | predicate name = do - -- Make sure it's actually on Hackage. Would be much more - -- efficient with some raw SQL and an inner join, but we - -- don't have a Conduit version of rawSql. - onHackage <- checkOnHackage nameid - pure $ if onHackage then Just name else Nothing - | otherwise = pure Nothing - - checkOnHackage nameid = do - cnt <- count [HackageCabalName ==. nameid] - pure $ cnt > 0 - --- | Get the filename for the cabal file in the given directory. --- --- If no .cabal file is present, or more than one is present, an exception is --- thrown via 'throwM'. --- --- If the directory contains a file named package.yaml, hpack is used to --- generate a .cabal file from it. -findOrGenerateCabalFile - :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Path Abs Dir -- ^ package directory - -> RIO env (P.PackageName, Path Abs File) -findOrGenerateCabalFile pkgDir = do - hpack pkgDir - files <- filter (flip hasExtension "cabal" . toFilePath) . snd - <$> listDir pkgDir - -- If there are multiple files, ignore files that start with - -- ".". On unixlike environments these are hidden, and this - -- character is not valid in package names. The main goal is - -- to ignore emacs lock files - see - -- https://github.com/commercialhaskell/stack/issues/1897. - let isHidden ('.':_) = True - isHidden _ = False - case filter (not . isHidden . fromRelFile . filename) files of - [] -> throwIO $ P.NoCabalFileFound pkgDir - [x] -> maybe - (throwIO $ P.InvalidCabalFilePath x) - (\pn -> pure $ (pn, x)) $ - List.stripSuffix ".cabal" (toFilePath (filename x)) >>= - P.parsePackageName - _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtension fp == "." ++ x - --- | Similar to 'hpackToCabal' but doesn't require a new connection to database. -hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.Tree - -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) -hpackToCabalS rpli tree = do - tmpDir <- lift $ do - tdir <- getTempDir - createTempDir tdir "hpack-pkg-dir" - unpackTreeToDir rpli tmpDir tree - (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir - !bs <- lift $ B.readFile (fromAbsFile cfile) - lift $ removeDirRecur tmpDir - return $ (packageName, bs) - -hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> P.Tree - -> RIO env (P.PackageName, ByteString) -hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do - tdir <- parseAbsDir tmpdir - withStorage $ unpackTreeToDir rpli tdir tree - (packageName, cfile) <- findOrGenerateCabalFile tdir - bs <- B.readFile (fromAbsFile cfile) - return (packageName, bs) - -unpackTreeToDir - :: (HasPantryConfig env, HasLogFunc env) - => P.RawPackageLocationImmutable -- ^ for exceptions - -> Path Abs Dir -- ^ dest dir, will be created if necessary - -> P.Tree - -> ReaderT SqlBackend (RIO env) () -unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do - for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do - let dest = dir T.unpack (P.unSafeFilePath sfp) - createDirectoryIfMissing True $ takeDirectory dest - mbs <- loadBlob blobKey - case mbs of - Nothing -> do - -- TODO when we have pantry wire stuff, try downloading - throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey - Just bs -> do - B.writeFile dest bs - case ft of - FTNormal -> pure () - FTExecutable -> liftIO $ do - perms <- getPermissions dest - setPermissions dest $ setOwnerExecutable True perms - -countHackageCabals :: ReaderT SqlBackend (RIO env) Int -countHackageCabals = do - res <- rawSql - "SELECT COUNT(*)\n\ - \FROM hackage_cabal" - [] - case res of - [] -> pure 0 - (Single n):_ -> - pure n - -getSnapshotCacheByHash - :: SnapshotCacheHash - -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) -getSnapshotCacheByHash = - fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash - -getSnapshotCacheId - :: SnapshotCacheHash - -> ReaderT SqlBackend (RIO env) SnapshotCacheId -getSnapshotCacheId = - fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash - -getModuleNameId - :: P.ModuleName - -> ReaderT SqlBackend (RIO env) ModuleNameId -getModuleNameId = - fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP - -storeSnapshotModuleCache - :: SnapshotCacheId - -> Map P.PackageName (Set P.ModuleName) - -> ReaderT SqlBackend (RIO env) () -storeSnapshotModuleCache cache packageModules = - forM_ (Map.toList packageModules) $ \(pn, modules) -> do - package <- getPackageNameId pn - forM_ modules $ \m -> do - moduleName <- getModuleNameId m - insert_ PackageExposedModule - { packageExposedModuleSnapshotCache = cache - , packageExposedModulePackage = package - , packageExposedModuleModule = moduleName - } - -loadExposedModulePackages - :: SnapshotCacheId - -> P.ModuleName - -> ReaderT SqlBackend (RIO env) [P.PackageName] -loadExposedModulePackages cacheId mName = - map go <$> rawSql - "SELECT package_name.name\n\ - \FROM package_name, package_exposed_module, module_name\n\ - \WHERE module_name.name=?\n\ - \AND package_exposed_module.snapshot_cache=?\n\ - \AND module_name.id=package_exposed_module.module\n\ - \AND package_name.id=package_exposed_module.package" - [ toPersistValue (P.ModuleNameP mName) - , toPersistValue cacheId - ] - where - go (Single (P.PackageNameP m)) = m - -data LoadCachedTreeException = MissingBlob !BlobKey - deriving (Show, Typeable) -instance Exception LoadCachedTreeException - --- | Ensure that all blobs needed for this package are present in the cache -loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) -loadCachedTree (P.TreeMap m) = - try $ CachedTreeMap <$> traverse loadEntry m - where - loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) - loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) - - loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId - loadBlob' blobKey@(P.BlobKey sha _) = do - mbid <- loadBlobBySHA sha - case mbid of - Nothing -> throwIO $ MissingBlob blobKey - Just bid -> pure bid +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.Storage + ( SqlBackend + , initStorage + , withStorage + , migrateAll + , storeBlob + , loadBlob + , loadBlobById + , loadBlobBySHA + , allBlobsSource + , allHackageCabalRawPackageLocations + , allBlobsCount + , allHackageCabalCount + , getBlobKey + , loadURLBlob + , storeURLBlob + , clearHackageRevisions + , storeHackageRevision + , loadHackagePackageVersions + , loadHackagePackageVersion + , loadLatestCacheUpdate + , storeCacheUpdate + , storeHackageTarballInfo + , loadHackageTarballInfo + , getHPackBlobKeyById + , storeTree + , loadTree + , storeHPack + , loadPackageById + , getPackageNameById + , getPackageNameId + , getVersionId + , getTreeForKey + , storeHackageTree + , loadHackageTree + , loadHackageTreeKey + , storeArchiveCache + , loadArchiveCache + , storeRepoCache + , loadRepoCache + , storePreferredVersion + , loadPreferredVersion + , sinkHackagePackageNames + , loadCabalBlobKey + , hpackToCabal + , countHackageCabals + , getSnapshotCacheByHash + , getSnapshotCacheId + , storeSnapshotModuleCache + , loadExposedModulePackages + , findOrGenerateCabalFile + , PackageNameId + , PackageName + , VersionId + , ModuleNameId + , Version + , versionVersion + , Unique(..) + , EntityField(..) + -- avoid warnings + , BlobId + , Key(unBlobKey) + , HackageCabalId + , HackageCabal(..) + , HackageTarballId + , CacheUpdateId + , FilePathId + , Tree(..) + , TreeId + , TreeEntry(..) + , TreeEntryId + , ArchiveCacheId + , RepoCacheId + , PreferredVersionsId + , UrlBlobId + , SnapshotCacheId + , PackageExposedModuleId + , loadCachedTree + , CachedTree (..) + , unCachedTree + ) where + +import RIO hiding (FilePath) +import RIO.Process +import qualified RIO.ByteString as B +import qualified Pantry.Types as P +import qualified RIO.List as List +import qualified RIO.FilePath as FilePath +import RIO.FilePath ((), takeDirectory) +import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.TH +import RIO.Orphans (HasResourceMap) +import qualified Pantry.SHA256 as SHA256 +import qualified RIO.Map as Map +import qualified RIO.Text as T +import RIO.Time (UTCTime, getCurrentTime) +import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) +import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) +import Pantry.HPack (hpackVersion, hpack) +import Conduit +import Data.Acquire (with) +import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..), connRDBMS) +import qualified Pantry.SQLite as SQLite + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +-- Raw blobs +Blob + sha SHA256 + size FileSize + contents ByteString + UniqueBlobSha sha +-- Previously downloaded blobs from given URLs. +-- May change over time, so we keep a time column too. +UrlBlob sql=url_blob + url Text + blob BlobId + time UTCTime + UniqueUrlTime url time + +-- For normalization, and avoiding storing strings in a bunch of +-- tables. +PackageName + name P.PackageNameP + UniquePackageName name +Version + version P.VersionP + UniqueVersion version +FilePath + path P.SafeFilePath + UniqueSfp path + +-- Secure download information for a package on Hackage. This does not +-- contain revision information, since sdist tarballs are (blessedly) +-- unmodified on Hackage. +HackageTarball + name PackageNameId + version VersionId + sha SHA256 + size FileSize + UniqueHackageTarball name version + +-- An individual cabal file from Hackage, representing a specific +-- revision. +HackageCabal + name PackageNameId + version VersionId + revision P.Revision + cabal BlobId + + -- If available: the full tree containing the HackageTarball + -- contents with the cabal file modified. + tree TreeId Maybe + UniqueHackage name version revision + +-- Any preferred-version information from Hackage +PreferredVersions + name PackageNameId + preferred Text + UniquePreferred name + +-- Last time we downloaded a 01-index.tar file from Hackage and +-- updated the three previous tables. +CacheUpdate + -- When did we do the update? + time UTCTime + + -- How big was the file when we updated, ignoring the last two + -- all-null 512-byte blocks. + size FileSize + + -- SHA256 of the first 'size' bytes of the file + sha SHA256 + +-- A tree containing a Haskell package. See associated TreeEntry +-- table. +Tree + key BlobId + + -- If the treeCabal field is Nothing, it means the Haskell package + -- doesn't have a corresponding cabal file for it. This may be the case + -- for haskell package referenced by git repository with only a hpack file. + cabal BlobId Maybe + cabalType FileType + name PackageNameId + version VersionId + UniqueTree key + +HPack + tree TreeId + + -- hpack version used for generating this cabal file + version VersionId + + -- Generated cabal file for the given tree and hpack version + cabalBlob BlobId + cabalPath FilePathId + + UniqueHPack tree version + +-- An individual file within a Tree. +TreeEntry + tree TreeId + path FilePathId + blob BlobId + type FileType + +-- Like UrlBlob, but stores the contents as a Tree. +ArchiveCache + time UTCTime + url Text + subdir Text + sha SHA256 + size FileSize + tree TreeId + +-- Like ArchiveCache, but for a Repo. +RepoCache + time UTCTime + url Text + type P.RepoType + commit Text + subdir Text + tree TreeId + +-- Identified by sha of all immutable packages contained in a snapshot +-- and GHC version used +SnapshotCache + sha SHA256 + UniqueSnapshotCache sha + +PackageExposedModule + snapshotCache SnapshotCacheId + module ModuleNameId + package PackageNameId + +ModuleName + name P.ModuleNameP + UniqueModule name +|] + +initStorage + :: HasLogFunc env + => Path Abs File -- ^ storage file + -> (P.Storage -> RIO env a) + -> RIO env a +initStorage = + SQLite.initStorage "Pantry" migrateAll + +withStorage + :: (HasPantryConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) a + -> RIO env a +withStorage action = do + storage <- view (P.pantryConfigL.to P.pcStorage) + SQLite.withStorage_ storage action + +-- | This is a helper type to distinguish db queries between different rdbms backends. The important +-- part is that the affects described in this data type should be semantically equivalent between +-- the supported engines. +data RdbmsActions env a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to SQLite + , raPostgres :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to PostgreSQL + } + +-- | This function provides a way to create queries supported by multiple sql backends. +rdbmsAwareQuery + :: RdbmsActions env a + -> ReaderT SqlBackend (RIO env) a +rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do + rdbms <- Pantry.Types.connRDBMS <$> ask + case rdbms of + "postgresql" -> raPostgres + "sqlite" -> raSqlite + _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" + + +getPackageNameById + :: PackageNameId + -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) +getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get + + +getPackageNameId + :: P.PackageName + -> ReaderT SqlBackend (RIO env) PackageNameId +getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP + +getVersionId + :: P.Version + -> ReaderT SqlBackend (RIO env) VersionId +getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP + +storeBlob + :: ByteString + -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) +storeBlob bs = do + let sha = SHA256.hashBytes bs + size = FileSize $ fromIntegral $ B.length bs + keys <- selectKeysList [BlobSha ==. sha] [] + key <- + case keys of + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = + insert Blob {blobSha = sha, blobSize = size, blobContents = bs} + , raPostgres = + do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [ toPersistValue sha + , toPersistValue size + , toPersistValue bs + ] + rawSql + "SELECT blob.id FROM blob WHERE blob.sha = ?" + [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> + error + "soreBlob: there was a critical problem storing a blob." + } + key:rest -> assert (null rest) (pure key) + pure (key, P.BlobKey sha size) + +loadBlob :: + HasLogFunc env + => BlobKey + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadBlob (P.BlobKey sha size) = do + ment <- getBy $ UniqueBlobSha sha + case ment of + Nothing -> pure Nothing + Just (Entity _ bt) + | blobSize bt == size -> pure $ Just $ blobContents bt + | otherwise -> + Nothing <$ lift (logWarn $ + "Mismatched blob size detected for SHA " <> display sha <> + ". Expected size: " <> display size <> + ". Actual size: " <> display (blobSize bt)) + +loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] + +loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString +loadBlobById bid = do + mbt <- get bid + case mbt of + Nothing -> error "loadBlobById: ID doesn't exist in database" + Just bt -> pure $ blobContents bt + +allBlobsSource :: + HasResourceMap env + => Maybe BlobId + -- ^ For some x, yield blob whose id>x. + -> ConduitT () (BlobId, ByteString) (ReaderT SqlBackend (RIO env)) () +allBlobsSource mblobId = + selectSource [BlobId >. blobId | Just blobId <- [mblobId]] [Asc BlobId] .| + mapC ((entityKey &&& blobContents . entityVal)) + +-- | Pull all hackage cabal entries from the database as +-- 'RawPackageLocationImmutable'. We do a manual join rather than +-- dropping to raw SQL, and Esqueleto would add more deps. +allHackageCabalRawPackageLocations :: + HasResourceMap env + => Maybe HackageCabalId + -- ^ For some x, yield cabals whose id>x. + -> ReaderT SqlBackend (RIO env) (Map.Map HackageCabalId P.RawPackageLocationImmutable) +allHackageCabalRawPackageLocations mhackageId = do + hackageCabals :: Map HackageCabalId HackageCabal <- + selectTuples + [HackageCabalId >. hackageId | Just hackageId <- [mhackageId]] + [] + packageNames :: Map PackageNameId PackageName <- selectTuples [] [] + versions :: Map VersionId Version <- selectTuples [] [] + for + hackageCabals + (\hackageCabal -> + case Map.lookup (hackageCabalName hackageCabal) packageNames of + Nothing -> error "no such package name" + Just packageName -> + let P.PackageNameP packageName' = packageNameName packageName + in case Map.lookup (hackageCabalVersion hackageCabal) versions of + Nothing -> error "no such version" + Just version -> + let P.VersionP version' = versionVersion version + in do mtree <- + case hackageCabalTree hackageCabal of + Just key -> selectFirst [TreeId ==. key] [] + Nothing -> pure Nothing + mblobKey <- + maybe + (pure Nothing) + (fmap Just . getBlobKey) + (fmap (treeKey . entityVal) mtree) + pure + (P.RPLIHackage + (P.PackageIdentifierRevision + packageName' + version' + (P.CFIRevision + (hackageCabalRevision hackageCabal))) + (fmap P.TreeKey mblobKey))) + where + selectTuples pred sort = + fmap (Map.fromList . map tuple) (selectList pred sort) + tuple (Entity k v) = (k, v) + +allBlobsCount :: Maybe BlobId -> ReaderT SqlBackend (RIO env) Int +allBlobsCount mblobId = count [BlobId >. blobId | Just blobId <- [mblobId]] + +allHackageCabalCount :: Maybe HackageCabalId -> ReaderT SqlBackend (RIO env) Int +allHackageCabalCount mhackageCabalId = + count + [ HackageCabalId >. hackageCabalId + | Just hackageCabalId <- [mhackageCabalId] + ] + +getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey +getBlobKey bid = do + res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] + case res of + [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid + [(Single sha, Single size)] -> pure $ P.BlobKey sha size + _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) + +getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +getBlobId (P.BlobKey sha size) = do + res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" + [toPersistValue sha, toPersistValue size] + pure $ listToMaybe $ map unSingle res + +loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadURLBlob url = do + ment <- rawSql + "SELECT blob.contents\n\ + \FROM blob, url_blob\n\ + \WHERE url=?\ + \ AND url_blob.blob=blob.id\n\ + \ ORDER BY url_blob.time DESC" + [toPersistValue url] + case ment of + [] -> pure Nothing + (Single bs) : _ -> pure $ Just bs + +storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () +storeURLBlob url blob = do + (blobId, _) <- storeBlob blob + now <- getCurrentTime + insert_ UrlBlob + { urlBlobUrl = url + , urlBlobBlob = blobId + , urlBlobTime = now + } + +clearHackageRevisions :: ReaderT SqlBackend (RIO env) () +clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) + +storeHackageRevision :: + P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () +storeHackageRevision name version key = do + nameid <- getPackageNameId name + versionid <- getVersionId version + rev <- count + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + ] + insert_ HackageCabal + { hackageCabalName = nameid + , hackageCabalVersion = versionid + , hackageCabalRevision = Revision (fromIntegral rev) + , hackageCabalCabal = key + , hackageCabalTree = Nothing + } + +loadHackagePackageVersions + :: P.PackageName + -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) +loadHackagePackageVersions name = do + nameid <- getPackageNameId name + -- would be better with esqueleto + (Map.fromListWith Map.union . map go) <$> rawSql + "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ + \FROM hackage_cabal as hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=version.id\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid] + where + go (Single revision, Single (P.VersionP version), Single key, Single size) = + (version, Map.singleton revision (P.BlobKey key size)) + +loadHackagePackageVersion + :: P.PackageName + -> P.Version + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) +loadHackagePackageVersion name version = do + nameid <- getPackageNameId name + versionid <- getVersionId version + -- would be better with esqueleto + (Map.fromList . map go) <$> rawSql + "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ + \FROM hackage_cabal as hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=?\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid, toPersistValue versionid] + where + go (Single revision, Single sha, Single size, Single bid) = + (revision, (bid, P.BlobKey sha size)) + +loadLatestCacheUpdate + :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) +loadLatestCacheUpdate = + fmap go <$> selectFirst [] [Desc CacheUpdateTime] + where + go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) + +storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () +storeCacheUpdate size sha = do + now <- getCurrentTime + insert_ CacheUpdate + { cacheUpdateTime = now + , cacheUpdateSize = size + , cacheUpdateSha = sha + } + +storeHackageTarballInfo + :: P.PackageName + -> P.Version + -> SHA256 + -> FileSize + -> ReaderT SqlBackend (RIO env) () +storeHackageTarballInfo name version sha size = do + nameid <- getPackageNameId name + versionid <- getVersionId version + void $ insertBy HackageTarball + { hackageTarballName = nameid + , hackageTarballVersion = versionid + , hackageTarballSha = sha + , hackageTarballSize = size + } + +loadHackageTarballInfo + :: P.PackageName + -> P.Version + -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) +loadHackageTarballInfo name version = do + nameid <- getPackageNameId name + versionid <- getVersionId version + fmap go <$> getBy (UniqueHackageTarball nameid versionid) + where + go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) + +storeCabalFile :: + ByteString + -> P.PackageName + -> ReaderT SqlBackend (RIO env) BlobId +storeCabalFile cabalBS pkgName = do + (bid, _) <- storeBlob cabalBS + let cabalFile = P.cabalFileName pkgName + _ <- insertBy FilePath {filePathPath = cabalFile} + return bid + +loadFilePath :: + SafeFilePath + -> ReaderT SqlBackend (RIO env) (Entity FilePath) +loadFilePath path = do + fp <- getBy $ UniqueSfp path + case fp of + Nothing -> + error $ + "loadFilePath: No row found for " <> + (T.unpack $ P.unSafeFilePath path) + Just record -> return record + +loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) +loadHPackTreeEntity tid = do + filepath <- loadFilePath P.hpackSafeFilePath + let filePathId :: FilePathId = entityKey filepath + hpackTreeEntry <- + selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] + case hpackTreeEntry of + Nothing -> + error $ + "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ + show tid + Just record -> return record + +storeHPack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable + -> TreeId + -> ReaderT SqlBackend (RIO env) (Key HPack) +storeHPack rpli tid = do + vid <- hpackVersionId + hpackRecord <- getBy (UniqueHPack tid vid) + case hpackRecord of + Nothing -> generateHPack rpli tid vid + Just record -> return $ entityKey record + +loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey +loadCabalBlobKey hpackId = do + hpackRecord <- getJust hpackId + getBlobKey $ hPackCabalBlob hpackRecord + +generateHPack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> TreeId + -> VersionId + -> ReaderT SqlBackend (RIO env) (Key HPack) +generateHPack rpli tid vid = do + tree <- getTree tid + (pkgName, cabalBS) <- hpackToCabalS rpli tree + bid <- storeCabalFile cabalBS pkgName + let cabalFile = P.cabalFileName pkgName + fid <- insertBy FilePath {filePathPath = cabalFile} + let hpackRecord = + HPack + { hPackTree = tid + , hPackVersion = vid + , hPackCabalBlob = bid + , hPackCabalPath = either entityKey id fid + } + either entityKey id <$> insertBy hpackRecord + + +hpackVersionId :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ReaderT SqlBackend (RIO env) VersionId +hpackVersionId = do + hpackSoftwareVersion <- lift hpackVersion + fmap (either entityKey id) $ + insertBy $ + Version {versionVersion = P.VersionP hpackSoftwareVersion} + + +getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId +getFilePathId sfp = + selectKeysList [FilePathPath ==. sfp] [] >>= \case + [fpId] -> pure fpId + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = insert $ FilePath sfp + , raPostgres = + do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql + "SELECT id FROM file_path WHERE path = ?" + [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> + error + "getFilePathId: there was a critical problem storing a blob." + } + _ -> + error $ + "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + where + fp = T.unpack (P.unSafeFilePath sfp) + +-- | A tree that has already been stored in the database +newtype CachedTree + = CachedTreeMap (Map SafeFilePath (P.TreeEntry, BlobId)) + deriving Show + +unCachedTree :: CachedTree -> P.Tree +unCachedTree (CachedTreeMap m) = P.TreeMap $ fst <$> m + +storeTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.PackageIdentifier + -> CachedTree + -> P.BuildFile + -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) +storeTree rpli (P.PackageIdentifier name version) tree@(CachedTreeMap m) buildFile = do + (bid, blobKey) <- storeBlob $ P.renderTree $ unCachedTree tree + (cabalid, ftype) <- case buildFile of + P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) + P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do + buildTypeid <- loadBlobBySHA btypeSha + buildid <- + case buildTypeid of + Just buildId -> pure buildId + Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) + return (Just buildid, ftype) + nameid <- getPackageNameId name + versionid <- getVersionId version + etid <- insertBy Tree + { treeKey = bid + , treeCabal = cabalid + , treeCabalType = ftype + , treeName = nameid + , treeVersion = versionid + } + + (tid, pTreeKey) <- case etid of + Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches + Right tid -> do + for_ (Map.toList m) $ \(sfp, (P.TreeEntry _blobKey ft, bid')) -> do + sfpid <- getFilePathId sfp + insert_ TreeEntry + { treeEntryTree = tid + , treeEntryPath = sfpid + , treeEntryBlob = bid' + , treeEntryType = ft + } + pure (tid, P.TreeKey blobKey) + case buildFile of + P.BFHpack _ -> storeHPack rpli tid >> return () + P.BFCabal _ _ -> return () + return (tid, pTreeKey) + +getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree +getTree tid = do + (mts :: Maybe Tree) <- get tid + ts <- + case mts of + Nothing -> + error $ "getTree: invalid foreign key " ++ show tid + Just ts -> pure ts + loadTreeByEnt $ Entity tid ts + +loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) +loadTree key = do + ment <- getTreeForKey key + case ment of + Nothing -> pure Nothing + Just ent -> Just <$> loadTreeByEnt ent + +getTreeForKey + :: TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) +getTreeForKey (P.TreeKey key) = do + mbid <- getBlobId key + case mbid of + Nothing -> pure Nothing + Just bid -> getBy $ UniqueTree bid + +loadPackageById :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> TreeId + -> ReaderT SqlBackend (RIO env) Package +loadPackageById rpli tid = do + (mts :: Maybe Tree) <- get tid + ts <- + case mts of + Nothing -> + error $ "loadPackageById: invalid foreign key " ++ show tid + Just ts -> pure ts + (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts + (blobKey :: BlobKey) <- getBlobKey $ treeKey ts + (mname :: Maybe PackageName) <- get $ treeName ts + name <- + case mname of + Nothing -> + error $ + "loadPackageByid: invalid foreign key " ++ show (treeName ts) + Just (PackageName (P.PackageNameP name)) -> pure name + mversion <- get $ treeVersion ts + version <- + case mversion of + Nothing -> + error $ + "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) + Just (Version (P.VersionP version)) -> pure version + let ident = P.PackageIdentifier name version + (packageEntry, mtree) <- + case treeCabal ts of + Just keyBlob -> do + cabalKey <- getBlobKey keyBlob + return + ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) + , tree) + Nothing -> do + hpackVid <- hpackVersionId + hpackEntity <- getBy (UniqueHPack tid hpackVid) + let (P.TreeMap tmap) = tree + cabalFile = P.cabalFileName name + case hpackEntity of + Nothing + -- This case will happen when you either + -- update stack with a new hpack version or + -- use different hpack version via + -- --with-hpack option. + -> do + (hpackId :: HPackId) <- storeHPack rpli tid + hpackRecord <- getJust hpackId + getHPackCabalFile hpackRecord ts tmap cabalFile + Just (Entity _ item) -> + getHPackCabalFile item ts tmap cabalFile + pure + Package + { packageTreeKey = P.TreeKey blobKey + , packageTree = mtree + , packageCabalEntry = packageEntry + , packageIdent = ident + } + +getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKey hpackRecord = do + let treeId = hPackTree hpackRecord + hpackEntity <- loadHPackTreeEntity treeId + getBlobKey (treeEntryBlob $ entityVal hpackEntity) + +getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKeyById hpackId = do + hpackRecord <- getJust hpackId + getHPackBlobKey hpackRecord + + +getHPackCabalFile :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => HPack + -> Tree + -> Map SafeFilePath P.TreeEntry + -> SafeFilePath + -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) +getHPackCabalFile hpackRecord ts tmap cabalFile = do + cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) + hpackKey <- getHPackBlobKey hpackRecord + hpackSoftwareVersion <- lift hpackVersion + let fileType = treeCabalType ts + cbTreeEntry = P.TreeEntry cabalKey fileType + hpackTreeEntry = P.TreeEntry hpackKey fileType + tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap + return + ( P.PCHpack $ + P.PHpack + { P.phOriginal = hpackTreeEntry + , P.phGenerated = cbTreeEntry + , P.phVersion = hpackSoftwareVersion + } + , tree) + +loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree +loadTreeByEnt (Entity tid _t) = do + entries <- rawSql + "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ + \FROM tree_entry, blob, file_path\n\ + \WHERE tree_entry.tree=?\n\ + \AND tree_entry.blob=blob.id\n\ + \AND tree_entry.path=file_path.id" + [toPersistValue tid] + pure $ P.TreeMap $ Map.fromList $ map + (\(Single sfp, Single sha, Single size, Single ft) -> + (sfp, P.TreeEntry (P.BlobKey sha size) ft)) + entries + +storeHackageTree + :: P.PackageName + -> P.Version + -> BlobId + -> P.TreeKey + -> ReaderT SqlBackend (RIO env) () +storeHackageTree name version cabal treeKey' = do + nameid <- getPackageNameId name + versionid <- getVersionId version + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> updateWhere + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. cabal + ] + [HackageCabalTree =. Just (entityKey ent)] + +loadHackageTreeKey + :: P.PackageName + -> P.Version + -> SHA256 + -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) +loadHackageTreeKey name ver sha = do + res <- rawSql + "SELECT treeblob.sha, treeblob.size\n\ + \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ + \WHERE package_name.name=?\n\ + \AND version.version=?\n\ + \AND cabalblob.sha=?\n\ + \AND hackage_cabal.name=package_name.id\n\ + \AND hackage_cabal.version=version.id\n\ + \AND hackage_cabal.cabal=cabalblob.id\n\ + \AND hackage_cabal.tree=tree.id\n\ + \AND tree.key=treeblob.id" + [ toPersistValue $ P.PackageNameP name + , toPersistValue $ P.VersionP ver + , toPersistValue sha + ] + case res of + [] -> pure Nothing + (Single treesha, Single size):_ -> + pure $ Just $ P.TreeKey $ P.BlobKey treesha size + +loadHackageTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.PackageName + -> P.Version + -> BlobId + -> ReaderT SqlBackend (RIO env) (Maybe Package) +loadHackageTree rpli name ver bid = do + nameid <- getPackageNameId name + versionid <- getVersionId ver + ment <- selectFirst + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. bid + , HackageCabalTree !=. Nothing + ] + [] + case ment of + Nothing -> pure Nothing + Just (Entity _ hc) -> + case hackageCabalTree hc of + Nothing -> assert False $ pure Nothing + Just tid -> Just <$> loadPackageById rpli tid + +storeArchiveCache + :: Text -- ^ URL + -> Text -- ^ subdir + -> SHA256 + -> FileSize + -> P.TreeKey + -> ReaderT SqlBackend (RIO env) () +storeArchiveCache url subdir sha size treeKey' = do + now <- getCurrentTime + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> insert_ ArchiveCache + { archiveCacheTime = now + , archiveCacheUrl = url + , archiveCacheSubdir = subdir + , archiveCacheSha = sha + , archiveCacheSize = size + , archiveCacheTree = entityKey ent + } + +loadArchiveCache + :: Text -- ^ URL + -> Text -- ^ subdir + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] +loadArchiveCache url subdir = map go <$> selectList + [ ArchiveCacheUrl ==. url + , ArchiveCacheSubdir ==. subdir + ] + [Desc ArchiveCacheTime] + where + go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) + +storeRepoCache + :: Repo + -> Text -- ^ subdir + -> TreeId + -> ReaderT SqlBackend (RIO env) () +storeRepoCache repo subdir tid = do + now <- getCurrentTime + insert_ RepoCache + { repoCacheTime = now + , repoCacheUrl = repoUrl repo + , repoCacheType = repoType repo + , repoCacheCommit = repoCommit repo + , repoCacheSubdir = subdir + , repoCacheTree = tid + } + +loadRepoCache + :: Repo + -> ReaderT SqlBackend (RIO env) (Maybe TreeId) +loadRepoCache repo = fmap (repoCacheTree . entityVal) <$> selectFirst + [ RepoCacheUrl ==. repoUrl repo + , RepoCacheType ==. repoType repo + , RepoCacheCommit ==. repoCommit repo + , RepoCacheSubdir ==. repoSubdir repo + ] + [Desc RepoCacheTime] + +storePreferredVersion :: + P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () +storePreferredVersion name p = do + nameid <- getPackageNameId name + ment <- getBy $ UniquePreferred nameid + case ment of + Nothing -> insert_ PreferredVersions + { preferredVersionsName = nameid + , preferredVersionsPreferred = p + } + Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] + +loadPreferredVersion :: + P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) +loadPreferredVersion name = do + nameid <- getPackageNameId name + fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) + +sinkHackagePackageNames + :: (P.PackageName -> Bool) + -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a + -> ReaderT SqlBackend (RIO env) a +sinkHackagePackageNames predicate sink = do + acqSrc <- selectSourceRes [] [] + with acqSrc $ \src -> runConduit + $ src + .| concatMapMC go + .| sink + where + go (Entity nameid (PackageName (PackageNameP name))) + | predicate name = do + -- Make sure it's actually on Hackage. Would be much more + -- efficient with some raw SQL and an inner join, but we + -- don't have a Conduit version of rawSql. + onHackage <- checkOnHackage nameid + pure $ if onHackage then Just name else Nothing + | otherwise = pure Nothing + + checkOnHackage nameid = do + cnt <- count [HackageCabalName ==. nameid] + pure $ cnt > 0 + +-- | Get the filename for the cabal file in the given directory. +-- +-- If no .cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, hpack is used to +-- generate a .cabal file from it. +findOrGenerateCabalFile + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (P.PackageName, Path Abs File) +findOrGenerateCabalFile pkgDir = do + hpack pkgDir + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . fromRelFile . filename) files of + [] -> throwIO $ P.NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ P.InvalidCabalFilePath x) + (\pn -> pure $ (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + P.parsePackageName + _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Similar to 'hpackToCabal' but doesn't require a new connection to database. +hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) +hpackToCabalS rpli tree = do + tmpDir <- lift $ do + tdir <- getTempDir + createTempDir tdir "hpack-pkg-dir" + unpackTreeToDir rpli tmpDir tree + (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir + !bs <- lift $ B.readFile (fromAbsFile cfile) + lift $ removeDirRecur tmpDir + return $ (packageName, bs) + +hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> RIO env (P.PackageName, ByteString) +hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do + tdir <- parseAbsDir tmpdir + withStorage $ unpackTreeToDir rpli tdir tree + (packageName, cfile) <- findOrGenerateCabalFile tdir + bs <- B.readFile (fromAbsFile cfile) + return (packageName, bs) + +unpackTreeToDir + :: (HasPantryConfig env, HasLogFunc env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> Path Abs Dir -- ^ dest dir, will be created if necessary + -> P.Tree + -> ReaderT SqlBackend (RIO env) () +unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do + for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do + let dest = dir T.unpack (P.unSafeFilePath sfp) + createDirectoryIfMissing True $ takeDirectory dest + mbs <- loadBlob blobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire stuff, try downloading + throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey + Just bs -> do + B.writeFile dest bs + case ft of + FTNormal -> pure () + FTExecutable -> liftIO $ do + perms <- getPermissions dest + setPermissions dest $ setOwnerExecutable True perms + +countHackageCabals :: ReaderT SqlBackend (RIO env) Int +countHackageCabals = do + res <- rawSql + "SELECT COUNT(*)\n\ + \FROM hackage_cabal" + [] + case res of + [] -> pure 0 + (Single n):_ -> + pure n + +getSnapshotCacheByHash + :: SnapshotCacheHash + -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) +getSnapshotCacheByHash = + fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash + +getSnapshotCacheId + :: SnapshotCacheHash + -> ReaderT SqlBackend (RIO env) SnapshotCacheId +getSnapshotCacheId = + fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash + +getModuleNameId + :: P.ModuleName + -> ReaderT SqlBackend (RIO env) ModuleNameId +getModuleNameId = + fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP + +storeSnapshotModuleCache + :: SnapshotCacheId + -> Map P.PackageName (Set P.ModuleName) + -> ReaderT SqlBackend (RIO env) () +storeSnapshotModuleCache cache packageModules = + forM_ (Map.toList packageModules) $ \(pn, modules) -> do + package <- getPackageNameId pn + forM_ modules $ \m -> do + moduleName <- getModuleNameId m + insert_ PackageExposedModule + { packageExposedModuleSnapshotCache = cache + , packageExposedModulePackage = package + , packageExposedModuleModule = moduleName + } + +loadExposedModulePackages + :: SnapshotCacheId + -> P.ModuleName + -> ReaderT SqlBackend (RIO env) [P.PackageName] +loadExposedModulePackages cacheId mName = + map go <$> rawSql + "SELECT package_name.name\n\ + \FROM package_name, package_exposed_module, module_name\n\ + \WHERE module_name.name=?\n\ + \AND package_exposed_module.snapshot_cache=?\n\ + \AND module_name.id=package_exposed_module.module\n\ + \AND package_name.id=package_exposed_module.package" + [ toPersistValue (P.ModuleNameP mName) + , toPersistValue cacheId + ] + where + go (Single (P.PackageNameP m)) = m + +data LoadCachedTreeException = MissingBlob !BlobKey + deriving (Show, Typeable) +instance Exception LoadCachedTreeException + +-- | Ensure that all blobs needed for this package are present in the cache +loadCachedTree :: forall env. P.Tree -> ReaderT SqlBackend (RIO env) (Either LoadCachedTreeException CachedTree) +loadCachedTree (P.TreeMap m) = + try $ CachedTreeMap <$> traverse loadEntry m + where + loadEntry :: P.TreeEntry -> ReaderT SqlBackend (RIO env) (P.TreeEntry, BlobId) + loadEntry te = (te, ) <$> loadBlob' (P.teBlob te) + + loadBlob' :: BlobKey -> ReaderT SqlBackend (RIO env) BlobId + loadBlob' blobKey@(P.BlobKey sha _) = do + mbid <- loadBlobBySHA sha + case mbid of + Nothing -> throwIO $ MissingBlob blobKey + Just bid -> pure bid diff --git a/src/Pantry/Tree.hs b/src/Pantry/Tree.hs --- a/src/Pantry/Tree.hs +++ b/src/Pantry/Tree.hs @@ -1,58 +1,58 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -module Pantry.Tree - ( unpackTree - , rawParseGPD - ) where - -import RIO -import qualified RIO.Map as Map -import qualified RIO.Text as T -import qualified RIO.ByteString as B -import Pantry.Storage hiding (Tree, TreeEntry) -import Pantry.Types -import RIO.FilePath ((), takeDirectory) -import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) -import Path (Path, Abs, Dir, toFilePath) -import Distribution.Parsec (PWarning (..)) -import Distribution.PackageDescription (GenericPackageDescription) -import Distribution.PackageDescription.Parsec -import Path (File) - -unpackTree - :: (HasPantryConfig env, HasLogFunc env) - => RawPackageLocationImmutable -- for exceptions - -> Path Abs Dir -- ^ dest dir, will be created if necessary - -> Tree - -> RIO env () -unpackTree rpli (toFilePath -> dir) (TreeMap m) = do - withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do - let dest = dir T.unpack (unSafeFilePath sfp) - createDirectoryIfMissing True $ takeDirectory dest - mbs <- loadBlob blobKey - case mbs of - Nothing -> do - -- TODO when we have pantry wire stuff, try downloading - throwIO $ TreeReferencesMissingBlob rpli sfp blobKey - Just bs -> do - B.writeFile dest bs - case ft of - FTNormal -> pure () - FTExecutable -> liftIO $ do - perms <- getPermissions dest - setPermissions dest $ setOwnerExecutable True perms - --- | A helper function that performs the basic character encoding --- necessary. -rawParseGPD - :: MonadThrow m - => Either RawPackageLocationImmutable (Path Abs File) - -> ByteString - -> m ([PWarning], GenericPackageDescription) -rawParseGPD loc bs = - case eres of - Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion (toList errs) warnings - Right gpkg -> return (warnings, gpkg) - where - (warnings, eres) = runParseResult $ parseGenericPackageDescription bs +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Pantry.Tree + ( unpackTree + , rawParseGPD + ) where + +import RIO +import qualified RIO.Map as Map +import qualified RIO.Text as T +import qualified RIO.ByteString as B +import Pantry.Storage hiding (Tree, TreeEntry) +import Pantry.Types +import RIO.FilePath ((), takeDirectory) +import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) +import Path (Path, Abs, Dir, toFilePath) +import Distribution.Parsec (PWarning (..)) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec +import Path (File) + +unpackTree + :: (HasPantryConfig env, HasLogFunc env) + => RawPackageLocationImmutable -- for exceptions + -> Path Abs Dir -- ^ dest dir, will be created if necessary + -> Tree + -> RIO env () +unpackTree rpli (toFilePath -> dir) (TreeMap m) = do + withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do + let dest = dir T.unpack (unSafeFilePath sfp) + createDirectoryIfMissing True $ takeDirectory dest + mbs <- loadBlob blobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire stuff, try downloading + throwIO $ TreeReferencesMissingBlob rpli sfp blobKey + Just bs -> do + B.writeFile dest bs + case ft of + FTNormal -> pure () + FTExecutable -> liftIO $ do + perms <- getPermissions dest + setPermissions dest $ setOwnerExecutable True perms + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD + :: MonadThrow m + => Either RawPackageLocationImmutable (Path Abs File) + -> ByteString + -> m ([PWarning], GenericPackageDescription) +rawParseGPD loc bs = + case eres of + Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion (toList errs) warnings + Right gpkg -> return (warnings, gpkg) + where + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -1,2404 +1,2404 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -module Pantry.Types - ( PantryConfig (..) - , HackageSecurityConfig (..) - , Storage (..) - , HasPantryConfig (..) - , BlobKey (..) - , PackageName - , Version - , PackageIdentifier (..) - , Revision (..) - , ModuleName - , CabalFileInfo (..) - , PrintWarnings (..) - , PackageNameP (..) - , VersionP (..) - , ModuleNameP (..) - , PackageIdentifierRevision (..) - , pirForHash - , FileType (..) - , BuildFile (..) - , FileSize (..) - , TreeEntry (..) - , SafeFilePath - , unSafeFilePath - , mkSafeFilePath - , safeFilePathtoPath - , hpackSafeFilePath - , TreeKey (..) - , Tree (..) - , renderTree - , parseTree - , parseTreeM - , SHA256 - , Unresolved - , resolvePaths - , Package (..) - , PackageCabal (..) - , PHpack (..) - -- , PackageTarball (..) - , RawPackageLocation (..) - , PackageLocation (..) - , toRawPL - , RawPackageLocationImmutable (..) - , PackageLocationImmutable (..) - , toRawPLI - , RawArchive (..) - , Archive (..) - , toRawArchive - , Repo (..) - , AggregateRepo (..) - , SimpleRepo (..) - , toAggregateRepos - , rToSimpleRepo - , arToSimpleRepo - , RepoType (..) - , parsePackageIdentifier - , parsePackageName - , parsePackageNameThrowing - , parseFlagName - , parseVersion - , parseVersionThrowing - , packageIdentifierString - , packageNameString - , flagNameString - , versionString - , moduleNameString - , OptionalSubdirs (..) - , ArchiveLocation (..) - , RelFilePath (..) - , CabalString (..) - , toCabalStringMap - , unCabalStringMap - , parsePackageIdentifierRevision - , Mismatch (..) - , PantryException (..) - , FuzzyResults (..) - , ResolvedPath (..) - , HpackExecutable (..) - , WantedCompiler (..) - --, resolveSnapshotLocation - , snapshotLocation - , defaultSnapshotLocation - , SnapName (..) - , parseSnapName - , RawSnapshotLocation (..) - , SnapshotLocation (..) - , toRawSL - , parseHackageText - , parseRawSnapshotLocation - , RawSnapshotLayer (..) - , SnapshotLayer (..) - , toRawSnapshotLayer - , RawSnapshot (..) - , Snapshot (..) - , RawSnapshotPackage (..) - , SnapshotPackage (..) - , parseWantedCompiler - , RawPackageMetadata (..) - , PackageMetadata (..) - , toRawPM - , cabalFileName - , SnapshotCacheHash (..) - , getGlobalHintsFile - , bsToBlobKey - , warnMissingCabalFile - , connRDBMS - ) where - -import RIO -import qualified Data.Conduit.Tar as Tar -import qualified RIO.Text as T -import qualified RIO.ByteString as B -import qualified RIO.ByteString.Lazy as BL -import RIO.List (intersperse, groupBy) -import RIO.Time (toGregorian, Day, UTCTime) -import qualified RIO.Map as Map -import qualified Data.Map.Strict as Map (mapKeysMonotonic) -import qualified RIO.Set as Set -import Data.Aeson.Types (toJSONKeyText, Parser) -import Pantry.Internal.AesonExtended -import Data.Aeson.Encoding.Internal (unsafeToEncoding) -import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) -import Database.Persist -import Database.Persist.Sql -import Pantry.SHA256 (SHA256) -import qualified Pantry.SHA256 as SHA256 -import qualified Distribution.Compat.CharParsing as Parse -import Distribution.CabalSpecVersion (cabalSpecLatest) -#if MIN_VERSION_Cabal(3,4,0) -import Distribution.CabalSpecVersion (cabalSpecToVersionDigits) -#else -import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -#endif -import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser) -import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) -import Distribution.Types.VersionRange (VersionRange) -import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) -import Distribution.Types.PackageId (PackageIdentifier (..)) -import qualified Distribution.Pretty -import qualified Distribution.Text -import qualified Hpack.Config as Hpack -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Version (Version, mkVersion, nullVersion) -import Network.HTTP.Client (parseRequest) -import Network.HTTP.Types (Status, statusCode) -import Data.Text.Read (decimal) -import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) -import Path.IO (resolveFile, resolveDir) -import qualified Data.List.NonEmpty as NE -import Casa.Client (CasaRepoPrefix) - -#if MIN_VERSION_persistent(2, 13, 0) -import Database.Persist.SqlBackend.Internal (connRDBMS) -#endif - -#if MIN_VERSION_aeson(2, 0, 0) -import qualified Data.Aeson.KeyMap as HM -import qualified Data.Aeson.Key - -type AesonKey = Data.Aeson.Key.Key -#else -import qualified RIO.HashMap as HM - -type AesonKey = Text -#endif - --- | Parsed tree with more information on the Haskell package it contains. --- --- @since 0.1.0.0 -data Package = Package - { packageTreeKey :: !TreeKey - -- ^ The 'TreeKey' containing this package. - -- - -- This is a hash of the binary representation of 'packageTree'. - -- - -- @since 0.1.0.0 - , packageTree :: !Tree - -- ^ The 'Tree' containing this package. - -- - -- @since 0.1.0.0 - , packageCabalEntry :: !PackageCabal - -- ^ Information on the cabal file inside this package. - -- - -- @since 0.1.0.0 - , packageIdent :: !PackageIdentifier - -- ^ The package name and version in this package. - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord) - -data PHpack = PHpack - { - phOriginal :: !TreeEntry, -- ^ Original hpack file - phGenerated :: !TreeEntry, -- ^ Generated Cabal file - phVersion :: !Version -- ^ Version of Hpack used - } deriving (Show, Eq, Ord) - -data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file - | PCHpack !PHpack - deriving (Show, Eq, Ord) - -cabalFileName :: PackageName -> SafeFilePath -cabalFileName name = - case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of - Nothing -> error $ "cabalFileName: failed for " ++ show name - Just sfp -> sfp - --- | The revision number of a package from Hackage, counting upwards --- from 0 (the original cabal file). --- --- See caveats on 'CFIRevision'. --- --- @since 0.1.0.0 -newtype Revision = Revision Word - deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) - --- | Represents a SQL database connection. This used to be a newtype --- wrapper around a connection pool. However, when investigating --- , it --- appeared that holding a pool resulted in overly long write locks --- being held on the database. As a result, we now abstract away --- whether a pool is used, and the default implementation in --- "Pantry.Storage" does not use a pool. -data Storage = Storage - { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a - , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a - } - --- | Configuration value used by the entire pantry package. Create one --- using @withPantryConfig@. See also @PantryApp@ for a convenience --- approach to using pantry. --- --- @since 0.1.0.0 -data PantryConfig = PantryConfig - { pcHackageSecurity :: !HackageSecurityConfig - , pcHpackExecutable :: !HpackExecutable - , pcRootDir :: !(Path Abs Dir) - , pcStorage :: !Storage - , pcUpdateRef :: !(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@. - , pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) - -- ^ Cache of previously parsed cabal files, to save on slow parsing time. - , pcParsedCabalFilesMutable :: - !(IORef - (Map - (Path Abs Dir) - (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File) - ) - ) - -- ^ Cache for mutable packages. We want to allow for an optimization: - -- deferring parsing of the 'GenericPackageDescription' until its actually - -- needed. Therefore, we keep the filepath and the 'PackageName' derived from - -- that filepath. When the @IO GenericPackageDescription@ is run, it will - -- ensure that the @PackageName@ matches the value inside the cabal file, and - -- print out any warnings that still need to be printed. - , pcConnectionCount :: !Int - -- ^ concurrently open downloads - , pcCasaRepoPrefix :: !CasaRepoPrefix - -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@ - , pcCasaMaxPerRequest :: !Int - -- ^ Maximum blobs sent per pull request. - , pcSnapshotLocation :: SnapName -> RawSnapshotLocation - -- ^ The location of snapshot synonyms - } - --- | Get the location of a snapshot synonym from the 'PantryConfig'. --- --- @since 0.5.0.0 -snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation -snapshotLocation name = do - loc <- view $ pantryConfigL.to pcSnapshotLocation - pure $ loc name - --- | Should we print warnings when loading a cabal file? --- --- @since 0.1.0.0 -data PrintWarnings = YesPrintWarnings | NoPrintWarnings - --- | Wraps a value which potentially contains relative paths. Needs to --- be provided with a base directory to resolve these paths. --- --- Unwrap this using 'resolvePaths'. --- --- @since 0.1.0.0 -newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) - deriving Functor -instance Applicative Unresolved where - pure = Unresolved . const . pure - Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir - --- | Resolve all of the file paths in an 'Unresolved' relative to the --- given directory. --- --- @since 0.1.0.0 -resolvePaths - :: MonadIO m - => Maybe (Path Abs Dir) -- ^ directory to use for relative paths - -> Unresolved a - -> m a -resolvePaths mdir (Unresolved f) = liftIO (f mdir) - --- | A combination of the relative path provided in a config file, --- together with the resolved absolute path. --- --- @since 0.1.0.0 -data ResolvedPath t = ResolvedPath - { resolvedRelative :: !RelFilePath - -- ^ Original value parsed from a config file. - , resolvedAbsolute :: !(Path Abs t) - -- ^ Absolute path resolved against base directory loaded from. - } - deriving (Show, Eq, Generic, Ord) -instance NFData (ResolvedPath t) - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected --- to change over time. Raw version doesn't include exact package --- version (e.g. could refer to the latest revision on Hackage) --- --- @since 0.1.0.0 -data RawPackageLocation - = RPLImmutable !RawPackageLocationImmutable - | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) -instance NFData RawPackageLocation - --- | Location to load a package from. Can either be immutable (see --- 'PackageLocationImmutable') or a local directory which is expected --- to change over time. --- --- @since 0.1.0.0 -data PackageLocation - = PLImmutable !PackageLocationImmutable - | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) -instance NFData PackageLocation - -instance Display PackageLocation where - display (PLImmutable loc) = display loc - display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp - --- | Convert `PackageLocation` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPL :: PackageLocation -> RawPackageLocation -toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) -toRawPL (PLMutable m) = RPLMutable m - --- | Location for remote packages or archives assumed to be immutable. --- as user specifies it i.e. not an exact location --- --- @since 0.1.0.0 -data RawPackageLocationImmutable - = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) - | RPLIArchive !RawArchive !RawPackageMetadata - | RPLIRepo !Repo !RawPackageMetadata - deriving (Show, Eq, Ord, Generic) - -instance NFData RawPackageLocationImmutable - -instance Display RawPackageLocationImmutable where - display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" - display (RPLIArchive archive _pm) = - "Archive from " <> display (raLocation archive) <> - (if T.null $ raSubdir archive - then mempty - else " in subdir " <> display (raSubdir archive)) - display (RPLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - --- | Location for remote packages or archives assumed to be immutable. --- --- @since 0.1.0.0 -data PackageLocationImmutable - = PLIHackage !PackageIdentifier !BlobKey !TreeKey - | PLIArchive !Archive !PackageMetadata - | PLIRepo !Repo !PackageMetadata - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData PackageLocationImmutable - -instance Display PackageLocationImmutable where - display (PLIHackage ident _cabalHash _tree) = - fromString (packageNameString $ pkgName ident) <> " (from Hackage)" - display (PLIArchive archive _pm) = - "Archive from " <> display (archiveLocation archive) <> - (if T.null $ archiveSubdir archive - then mempty - else " in subdir " <> display (archiveSubdir archive)) - display (PLIRepo repo _pm) = - "Repo from " <> display (repoUrl repo) <> - ", commit " <> display (repoCommit repo) <> - (if T.null $ repoSubdir repo - then mempty - else " in subdir " <> display (repoSubdir repo)) - -instance ToJSON PackageLocationImmutable where - toJSON = toJSON . toRawPLI - --- | Package identifier and revision with a specified cabal file hash --- --- @since 0.1.0.0 -pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision -pirForHash (PackageIdentifier name ver) (BlobKey sha size') = - let cfi = CFIHash sha (Just size') - in PackageIdentifierRevision name ver cfi - --- | Convert `PackageLocationImmutable` to its "raw" equivalent --- --- @since 0.1.0.0 -toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable -toRawPLI (PLIHackage ident cfKey treeKey) = RPLIHackage (pirForHash ident cfKey) (Just treeKey) -toRawPLI (PLIArchive archive pm) = RPLIArchive (toRawArchive archive) (toRawPM pm) -toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) - --- | A raw package archive, specified by a user, could have no --- hash and file size information. --- --- @since 0.1.0.0 -data RawArchive = RawArchive - { raLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , raHash :: !(Maybe SHA256) - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , raSize :: !(Maybe FileSize) - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , raSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) - -instance NFData RawArchive - --- | A package archive, could be from a URL or a local file --- path. Local file path archives are assumed to be unchanging --- over time, and so are allowed in custom snapshots. --- --- @since 0.1.0.0 -data Archive = Archive - { archiveLocation :: !ArchiveLocation - -- ^ Location of the archive - -- - -- @since 0.1.0.0 - , archiveHash :: !SHA256 - -- ^ Cryptographic hash of the archive file - -- - -- @since 0.1.0.0 - , archiveSize :: !FileSize - -- ^ Size of the archive file - -- - -- @since 0.1.0.0 - , archiveSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData Archive - --- | Convert archive to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawArchive :: Archive -> RawArchive -toRawArchive archive = - RawArchive (archiveLocation archive) (Just $ archiveHash archive) - (Just $ archiveSize archive) (archiveSubdir archive) - --- | The type of a source control repository. --- --- @since 0.1.0.0 -data RepoType = RepoGit | RepoHg - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData RepoType -instance PersistField RepoType where - toPersistValue RepoGit = toPersistValue (1 :: Int32) - toPersistValue RepoHg = toPersistValue (2 :: Int32) - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int32 of - 1 -> pure RepoGit - 2 -> pure RepoHg - _ -> Left $ fromString $ "Invalid RepoType: " ++ show i -instance PersistFieldSql RepoType where - sqlType _ = SqlInt32 - --- | Information on packages stored in a source control repository. --- --- @since 0.1.0.0 -data Repo = Repo - { repoUrl :: !Text - -- ^ Location of the repo - -- - -- @since 0.1.0.0 - , repoCommit :: !Text - -- ^ Commit to use from the repo. It's strongly recommended to use - -- a hash instead of a tag or branch name. - -- - -- @since 0.1.0.0 - , repoType :: !RepoType - -- ^ The type of the repo - -- - -- @since 0.1.0.0 - , repoSubdir :: !Text - -- ^ Subdirectory within the archive to get the package from. - -- - -- @since 0.1.0.0 - } - deriving (Generic, Eq, Ord, Typeable) -instance NFData Repo -instance Show Repo where - show = T.unpack . utf8BuilderToText . display -instance Display Repo where - display (Repo url commit typ subdir) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit <> - (if T.null subdir - then mempty - else " in subdirectory " <> display subdir) - -rToSimpleRepo :: Repo -> SimpleRepo -rToSimpleRepo Repo {..} = SimpleRepo { sRepoUrl = repoUrl, sRepoCommit = repoCommit, sRepoType = repoType } - -data AggregateRepo = AggregateRepo - { aRepo :: !SimpleRepo - , aRepoSubdirs :: [(Text, RawPackageMetadata)] - } - deriving (Show, Generic, Eq, Ord, Typeable) - --- | Group input repositories by non-subdir values. -toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] -toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir - where - toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo - toAggregateRepo [] = Nothing - toAggregateRepo xs@((repo, _):_) = - Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) - - matchRepoExclSubdir x1 x2 = - let (Repo url1 commit1 type1 _, _) = x1 - (Repo url2 commit2 type2 _, _) = x2 - in (url1, commit1, type1) == (url2, commit2, type2) - -arToSimpleRepo :: AggregateRepo -> SimpleRepo -arToSimpleRepo AggregateRepo {..} = aRepo - --- | Repository without subdirectory information. --- --- @since 0.5.3 -data SimpleRepo = SimpleRepo - { sRepoUrl :: !Text - , sRepoCommit :: !Text - , sRepoType :: !RepoType - } - deriving (Show, Generic, Eq, Ord, Typeable) - -instance Display SimpleRepo where - display (SimpleRepo url commit typ) = - (case typ of - RepoGit -> "Git" - RepoHg -> "Mercurial") <> - " repo at " <> - display url <> - ", commit " <> - display commit - --- 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\"" - --- | Configuration for Hackage Security to securely download package --- metadata and contents from Hackage. For most purposes, you'll want --- to use the default Hackage settings via --- @defaultHackageSecurityConfig@. --- --- /NOTE/ It's highly recommended to only use the official Hackage --- server or a mirror. See --- . --- --- @since 0.1.0.0 -data HackageSecurityConfig = HackageSecurityConfig - { hscKeyIds :: ![Text] - , hscKeyThreshold :: !Int - , hscDownloadPrefix :: !Text - , hscIgnoreExpiry :: !Bool - } - deriving Show -instance FromJSON (WithJSONWarnings HackageSecurityConfig) where - parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do - hscDownloadPrefix <- o' ..: "download-prefix" - Object o <- o' ..: "hackage-security" - hscKeyIds <- o ..: "keyids" - hscKeyThreshold <- o ..: "key-threshold" - hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True - pure HackageSecurityConfig {..} - - --- | An environment which contains a 'PantryConfig'. --- --- @since 0.1.0.0 -class HasPantryConfig env where - -- | Lens to get or set the 'PantryConfig' - -- - -- @since 0.1.0.0 - pantryConfigL :: Lens' env PantryConfig - - --- | File size in bytes --- --- @since 0.1.0.0 -newtype FileSize = FileSize Word - deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON) - --- | A key for looking up a blob, which combines the SHA256 hash of --- the contents and the file size. --- --- The file size may seem redundant with the hash. However, it is --- necessary for safely downloading blobs from an untrusted --- source. See --- . --- --- @since 0.1.0.0 -data BlobKey = BlobKey !SHA256 !FileSize - deriving (Eq, Ord, Typeable, Generic) -instance NFData BlobKey - -instance Show BlobKey where - show = T.unpack . utf8BuilderToText . display -instance Display BlobKey where - display (BlobKey sha size') = display sha <> "," <> display size' - -blobKeyPairs :: BlobKey -> [(AesonKey, Value)] -blobKeyPairs (BlobKey sha size') = - [ "sha256" .= sha - , "size" .= size' - ] - -instance ToJSON BlobKey where - toJSON = object . blobKeyPairs -instance FromJSON BlobKey where - parseJSON = withObject "BlobKey" $ \o -> BlobKey - <$> o .: "sha256" - <*> o .: "size" - -newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } - deriving (Eq, Ord, Show, Read, NFData) -instance Display PackageNameP where - display = fromString . packageNameString . unPackageNameP -instance PersistField PackageNameP where - toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn - fromPersistValue v = do - str <- fromPersistValue v - case parsePackageName str of - Nothing -> Left $ "Invalid package name: " <> T.pack str - Just pn -> Right $ PackageNameP pn -instance PersistFieldSql PackageNameP where - sqlType _ = SqlString -instance ToJSON PackageNameP where - toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn -instance FromJSON PackageNameP where - parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack -instance ToJSONKey PackageNameP where - toJSONKey = - ToJSONKeyText - (fromString . packageNameString . unPackageNameP) - (unsafeToEncoding . getUtf8Builder . display) -instance FromJSONKey PackageNameP where - fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack - -newtype VersionP = VersionP { unVersionP :: Version } - deriving (Eq, Ord, Show, Read, NFData) -instance PersistField VersionP where - toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v - fromPersistValue v = do - str <- fromPersistValue v - case parseVersion str of - Nothing -> Left $ "Invalid version number: " <> T.pack str - Just ver -> Right $ VersionP ver -instance PersistFieldSql VersionP where - sqlType _ = SqlString -instance Display VersionP where - display (VersionP v) = fromString $ versionString v -instance ToJSON VersionP where - toJSON (VersionP v) = String $ T.pack $ versionString v -instance FromJSON VersionP where - parseJSON = - withText "VersionP" $ - either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack - -newtype ModuleNameP = ModuleNameP - { unModuleNameP :: ModuleName - } deriving (Eq, Ord, Show, NFData) -instance Display ModuleNameP where - display = fromString . moduleNameString . unModuleNameP -instance PersistField ModuleNameP where - toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn - fromPersistValue v = do - str <- fromPersistValue v - case parseModuleName str of - Nothing -> Left $ "Invalid module name: " <> T.pack str - Just pn -> Right $ ModuleNameP pn -instance PersistFieldSql ModuleNameP where - sqlType _ = SqlString - --- | How to choose a cabal file for a package from Hackage. This is to --- work with Hackage cabal file revisions, which makes --- @PackageIdentifier@ insufficient for specifying a package from --- Hackage. --- --- @since 0.1.0.0 -data CabalFileInfo - = CFILatest - -- ^ Take the latest revision of the cabal file available. This - -- isn't reproducible at all, but the running assumption (not - -- necessarily true) is that cabal file revisions do not change - -- semantics of the build. - -- - -- @since 0.1.0.0 - | CFIHash !SHA256 !(Maybe FileSize) - -- ^ Identify by contents of the cabal file itself. Only reason for - -- @Maybe@ on @FileSize@ is for compatibility with input that - -- doesn't include the file size. - -- - -- @since 0.1.0.0 - | CFIRevision !Revision - -- ^ Identify by revision number, with 0 being the original and - -- counting upward. This relies on Hackage providing consistent - -- versioning. @CFIHash@ should be preferred wherever possible for - -- reproducibility. - -- - -- @since 0.1.0.0 - deriving (Generic, Show, Eq, Ord, Typeable) -instance NFData CabalFileInfo -instance Hashable CabalFileInfo - -instance Display CabalFileInfo where - display CFILatest = mempty - display (CFIHash hash' msize) = - "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize - display (CFIRevision rev) = "@rev:" <> display rev - --- | A full specification for a package from Hackage, including the --- package name, version, and how to load up the correct cabal file --- revision. --- --- @since 0.1.0.0 -data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo - deriving (Generic, Eq, Ord, Typeable) -instance NFData PackageIdentifierRevision - -instance Show PackageIdentifierRevision where - show = T.unpack . utf8BuilderToText . display - -instance Display PackageIdentifierRevision where - display (PackageIdentifierRevision name version cfi) = - fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi - -instance ToJSON PackageIdentifierRevision where - toJSON = toJSON . utf8BuilderToText . display -instance FromJSON PackageIdentifierRevision where - parseJSON = withText "PackageIdentifierRevision" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure pir - --- | Parse a hackage text. --- --- @since 0.1.0.0 -parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) -parseHackageText t = - either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ - explicitEitherParsec (hackageTextParsec <* Parse.eof) $ - T.unpack t - -hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) -hackageTextParsec = do - ident <- packageIdentifierParsec - _ <- Parse.string "@sha256:" - - shaT <- Parse.munch (/= ',') - sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT - - _ <- Parse.char ',' - size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't - pure (ident, BlobKey sha (FileSize size')) - -splitColon :: Text -> Maybe (Text, Text) -splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y - --- | Parse a 'PackageIdentifierRevision' --- --- @since 0.1.0.0 -parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision -parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do - let (identT, cfiT) = T.break (== '@') t - PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT - cfi <- - case splitColon cfiT of - Just ("@sha256", shaSizeT) -> do - let (shaT, sizeT) = T.break (== ',') shaSizeT - sha <- either (const Nothing) Just $ SHA256.fromHexText shaT - msize <- - case T.stripPrefix "," sizeT of - Nothing -> Just Nothing - Just sizeT' -> - case decimal sizeT' of - Right (size', "") -> Just $ Just $ FileSize size' - _ -> Nothing - pure $ CFIHash sha msize - Just ("@rev", revT) -> - case decimal revT of - Right (rev, "") -> pure $ CFIRevision $ Revision rev - _ -> Nothing - Nothing -> pure CFILatest - _ -> Nothing - pure $ PackageIdentifierRevision name version cfi - -data Mismatch a = Mismatch - { mismatchExpected :: !a - , mismatchActual :: !a - } - --- | Things that can go wrong in pantry. Note two things: --- --- * Many other exception types may be thrown from underlying --- libraries. Pantry does not attempt to wrap these underlying --- exceptions. --- --- * We may add more constructors to this data type in minor version --- bumps of pantry. This technically breaks the PVP. You should not --- be writing pattern matches against this type that expect total --- matching. --- --- @since 0.1.0.0 -data PantryException - = PackageIdentifierRevisionParseFail !Text - | InvalidCabalFile - !(Either RawPackageLocationImmutable (Path Abs File)) - !(Maybe Version) - ![PError] - ![PWarning] - | TreeWithoutCabalFile !RawPackageLocationImmutable - | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] - | MismatchedCabalName !(Path Abs File) !PackageName - | NoCabalFileFound !(Path Abs Dir) - | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] - | InvalidWantedCompiler !Text - | InvalidSnapshotLocation !(Path Abs Dir) !Text - | InvalidOverrideCompiler !WantedCompiler !WantedCompiler - | InvalidFilePathSnapshot !Text - | InvalidSnapshot !RawSnapshotLocation !SomeException - | MismatchedPackageMetadata - !RawPackageLocationImmutable - !RawPackageMetadata - !(Maybe TreeKey) - !PackageIdentifier - | Non200ResponseStatus !Status - | InvalidBlobKey !(Mismatch BlobKey) - | Couldn'tParseSnapshot !RawSnapshotLocation !String - | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName - | DownloadInvalidSHA256 !Text !(Mismatch SHA256) - | DownloadInvalidSize !Text !(Mismatch FileSize) - | DownloadTooLarge !Text !(Mismatch FileSize) - -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is - -- a lower bound on the size from the server. - | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) - | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) - | UnknownArchiveType !ArchiveLocation - | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType - | UnsupportedTarball !ArchiveLocation !Text - | NoHackageCryptographicHash !PackageIdentifier - | FailedToCloneRepo !SimpleRepo - | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey - | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata - | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) - | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults - | CannotCompleteRepoNonSHA1 !Repo - | MutablePackageLocationFromUrl !Text - | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) - | PackageNameParseFail !Text - | PackageVersionParseFail !Text - | InvalidCabalFilePath !(Path Abs File) - | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] - | MigrationFailure !Text !(Path Abs File) !SomeException - | InvalidTreeFromCasa !BlobKey !ByteString - | ParseSnapNameException !Text - - deriving Typeable -instance Exception PantryException where -instance Show PantryException where - show = T.unpack . utf8BuilderToText . display -instance Display PantryException where - display (InvalidTreeFromCasa blobKey _bs) = "Invalid tree from casa: " <> display blobKey - display (PackageIdentifierRevisionParseFail text) = - "Invalid package identifier (with optional revision): " <> - display text - display (InvalidCabalFile loc mversion errs warnings) = - "Unable to parse cabal file from package " <> - either display (fromString . toFilePath) loc <> - "\n\n" <> - foldMap - (\(PError pos msg) -> - "- " <> - fromString (showPos pos) <> - ": " <> - fromString msg <> - "\n") - errs <> - foldMap - (\(PWarning _ pos msg) -> - "- " <> - fromString (showPos pos) <> - ": " <> - fromString msg <> - "\n") - warnings <> - - (case mversion of - Just version - | version > cabalSpecLatestVersion -> - "\n\nThe cabal file uses the cabal specification version " <> - fromString (versionString version) <> - ", but we only support up to version " <> - fromString (versionString cabalSpecLatestVersion) <> - ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." - _ -> mempty) - display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl - display (TreeWithMultipleCabalFiles pl sfps) = - "Multiple cabal files found for " <> display pl <> ": " <> - fold (intersperse ", " (map display sfps)) - display (MismatchedCabalName fp name) = - "cabal file path " <> - fromString (toFilePath fp) <> - " does not match the package name it defines.\n" <> - "Please rename the file to: " <> - fromString (packageNameString name) <> - ".cabal\n" <> - "For more information, see: https://github.com/commercialhaskell/stack/issues/317" - display (NoCabalFileFound dir) = - "Stack looks for packages in the directories configured in\n" <> - "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> - "The current entry points to " <> - fromString (toFilePath dir) <> - ",\nbut no .cabal or package.yaml file could be found there." - display (MultipleCabalFilesFound dir files) = - "Multiple .cabal files found in directory " <> - fromString (toFilePath dir) <> - ":\n" <> - fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) - display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t - display (InvalidSnapshotLocation dir t) = - "Invalid snapshot location " <> - displayShow t <> - " relative to directory " <> - displayShow (toFilePath dir) - display (InvalidOverrideCompiler x y) = - "Specified compiler for a resolver (" <> - display x <> - "), but also specified an override compiler (" <> - display y <> - ")" - display (InvalidFilePathSnapshot t) = - "Specified snapshot as file path with " <> - displayShow t <> - ", but not reading from a local file" - display (InvalidSnapshot loc e) = - "Exception while reading snapshot from " <> - display loc <> - ":\n" <> - displayShow e - display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = - "Mismatched package metadata for " <> display loc <> - "\nFound: " <> fromString (packageIdentifierString foundIdent) <> - (case mtreeKey of - Nothing -> mempty - Just treeKey -> " with tree " <> display treeKey) <> - "\nExpected: " <> display pm - display (Non200ResponseStatus status) = - "Unexpected non-200 HTTP status code: " <> - displayShow (statusCode status) - display (InvalidBlobKey Mismatch{..}) = - "Invalid blob key found, expected: " <> - display mismatchExpected <> - ", actual: " <> - display mismatchActual - display (Couldn'tParseSnapshot sl e) = - "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e - display (WrongCabalFileName pl sfp name) = - "Wrong cabal file name for package " <> display pl <> - "\nCabal file is named " <> display sfp <> - ", but package name is " <> fromString (packageNameString name) <> - "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" - display (DownloadInvalidSHA256 url Mismatch {..}) = - "Mismatched SHA256 hash from " <> display url <> - "\nExpected: " <> display mismatchExpected <> - "\nActual: " <> display mismatchActual - display (DownloadInvalidSize url Mismatch {..}) = - "Mismatched download size from " <> display url <> - "\nExpected: " <> display mismatchExpected <> - "\nActual: " <> display mismatchActual - display (DownloadTooLarge url Mismatch {..}) = - "Download from " <> display url <> " was too large.\n" <> - "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> - display mismatchActual - display (LocalInvalidSHA256 path Mismatch {..}) = - "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> - "\nExpected: " <> display mismatchExpected <> - "\nActual: " <> display mismatchActual - display (LocalInvalidSize path Mismatch {..}) = - "Mismatched file size from " <> fromString (toFilePath path) <> - "\nExpected: " <> display mismatchExpected <> - "\nActual: " <> display mismatchActual - display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc - display (InvalidTarFileType loc fp x) = - "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x - display (UnsupportedTarball loc e) = - "Unsupported tarball from " <> display loc <> ": " <> display e - display (NoHackageCryptographicHash ident) = - "Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) - display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo - display (TreeReferencesMissingBlob loc sfp key) = - "The package " <> display loc <> - " needs blob " <> display key <> - " for file path " <> display sfp <> - ", but the blob is not available" - display (CompletePackageMetadataMismatch loc pm) = - "When completing package metadata for " <> display loc <> - ", some values changed in the new package metadata: " <> - display pm - display (CRC32Mismatch loc fp Mismatch {..}) = - "CRC32 mismatch in ZIP file from " <> display loc <> - " on internal file " <> fromString fp <> - "\n.Expected: " <> display mismatchExpected <> - "\n.Actual: " <> display mismatchActual - display (UnknownHackagePackage pir fuzzy) = - "Could not find " <> display pir <> " on Hackage" <> - displayFuzzy fuzzy - display (CannotCompleteRepoNonSHA1 repo) = - "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> - display repo - display (MutablePackageLocationFromUrl t) = - "Cannot refer to a mutable package location from a URL: " <> display t - display (MismatchedCabalFileForHackage pir Mismatch{..}) = - "When processing cabal file for Hackage package " <> display pir <> - ":\nMismatched package identifier." <> - "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> - "\nActual: " <> fromString (packageIdentifierString mismatchActual) - display (PackageNameParseFail t) = - "Invalid package name: " <> display t - display (PackageVersionParseFail t) = - "Invalid version: " <> display t - display (InvalidCabalFilePath fp) = - "File path contains a name which is not a valid package name: " <> - fromString (toFilePath fp) - display (DuplicatePackageNames source pairs') = - "Duplicate package names (" <> source <> "):\n" <> - foldMap - (\(name, locs) -> - fromString (packageNameString name) <> ":\n" <> - foldMap - (\loc -> "- " <> display loc <> "\n") - locs - ) - pairs' - display (MigrationFailure desc fp ex) = - "Encountered error while migrating " <> display desc <> " database:" <> - "\n " <> displayShow ex <> - "\nPlease report this on https://github.com/commercialhaskell/stack/issues" <> - "\nAs a workaround you may delete " <> display desc <> " database in " <> - fromString (toFilePath fp) <> " triggering its recreation." - display (ParseSnapNameException t) = "Invalid snapshot name: " <> display t - -data FuzzyResults - = FRNameNotFound ![PackageName] - | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) - | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) - -displayFuzzy :: FuzzyResults -> Utf8Builder -displayFuzzy (FRNameNotFound names) = - case NE.nonEmpty names of - Nothing -> "" - Just names' -> - "\nPerhaps you meant " <> - orSeparated (NE.map (fromString . packageNameString) names') <> - "?" -displayFuzzy (FRVersionNotFound pirs) = - "\nPossible candidates: " <> - commaSeparated (NE.map display pirs) <> - "." -displayFuzzy (FRRevisionNotFound pirs) = - "\nThe specified revision was not found.\nPossible candidates: " <> - commaSeparated (NE.map display pirs) <> - "." - -orSeparated :: NonEmpty Utf8Builder -> Utf8Builder -orSeparated xs - | NE.length xs == 1 = NE.head xs - | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs - | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs - -commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder -commaSeparated = fold . NE.intersperse ", " - -cabalSpecLatestVersion :: Version -cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest - -#if !MIN_VERSION_Cabal(3,4,0) -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] -#endif - -data BuildFile = BFCabal !SafeFilePath !TreeEntry - | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file - deriving (Show, Eq) - -data FileType = FTNormal | FTExecutable - deriving (Show, Eq, Enum, Bounded, Ord) -instance PersistField FileType where - toPersistValue FTNormal = PersistInt64 1 - toPersistValue FTExecutable = PersistInt64 2 - - fromPersistValue v = do - i <- fromPersistValue v - case i :: Int64 of - 1 -> Right FTNormal - 2 -> Right FTExecutable - _ -> Left $ "Invalid FileType: " <> tshow i -instance PersistFieldSql FileType where - sqlType _ = SqlInt32 - -data TreeEntry = TreeEntry - { teBlob :: !BlobKey - , teType :: !FileType - } - deriving (Show, Eq, Ord) - -newtype SafeFilePath = SafeFilePath Text - deriving (Show, Eq, Ord, Display) - -instance PersistField SafeFilePath where - toPersistValue = toPersistValue . unSafeFilePath - fromPersistValue v = do - t <- fromPersistValue v - maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t -instance PersistFieldSql SafeFilePath where - sqlType _ = SqlString - -unSafeFilePath :: SafeFilePath -> Text -unSafeFilePath (SafeFilePath t) = t - -safeFilePathtoPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) -safeFilePathtoPath dir (SafeFilePath path) = do - fpath <- parseRelFile (T.unpack path) - return $ dir fpath - -mkSafeFilePath :: Text -> Maybe SafeFilePath -mkSafeFilePath t = do - guard $ not $ "\\" `T.isInfixOf` t - guard $ not $ "//" `T.isInfixOf` t - guard $ not $ "\n" `T.isInfixOf` t - guard $ not $ "\0" `T.isInfixOf` t - - (c, _) <- T.uncons t - guard $ c /= '/' - - guard $ all (not . T.all (== '.')) $ T.split (== '/') t - - Just $ SafeFilePath t - --- | SafeFilePath for `package.yaml` file. -hpackSafeFilePath :: SafeFilePath -hpackSafeFilePath = - let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) - in case fpath of - Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) - Just sfp -> sfp - --- | The hash of the binary representation of a 'Tree'. --- --- @since 0.1.0.0 -newtype TreeKey = TreeKey BlobKey - deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) - --- | Represents the contents of a tree, which is a mapping from --- relative file paths to 'TreeEntry's. --- --- @since 0.1.0.0 -newtype Tree - = TreeMap (Map SafeFilePath TreeEntry) - -- In the future, consider allowing more lax parsing - -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys - -- TreeTarball !PackageTarball - deriving (Show, Eq, Ord) - -renderTree :: Tree -> ByteString -renderTree = BL.toStrict . toLazyByteString . go - where - go :: Tree -> Builder - go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m - - goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = - netstring (unSafeFilePath sfp) <> - byteString (SHA256.toRaw sha) <> - netword size' <> - (case ft of - FTNormal -> "N" - FTExecutable -> "X") - -netstring :: Text -> Builder -netstring t = - let bs = encodeUtf8 t - in netword (fromIntegral (B.length bs)) <> byteString bs - -netword :: Word -> Builder -netword w = wordDec w <> ":" - -parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) -parseTreeM (blobKey, blob) = - case parseTree blob of - Nothing -> throwM (InvalidTreeFromCasa blobKey blob) - Just tree -> pure (TreeKey blobKey, tree) - -parseTree :: ByteString -> Maybe Tree -parseTree bs1 = do - tree <- parseTree' bs1 - let bs2 = renderTree tree - guard $ bs1 == bs2 - Just tree - -parseTree' :: ByteString -> Maybe Tree -parseTree' bs0 = do - entriesBS <- B.stripPrefix "map:" bs0 - TreeMap <$> loop Map.empty entriesBS - where - loop !m bs1 - | B.null bs1 = pure m - | otherwise = do - (sfpBS, bs2) <- takeNetstring bs1 - sfp <- - case decodeUtf8' sfpBS of - Left _ -> Nothing - Right sfpT -> mkSafeFilePath sfpT - (sha, bs3) <- takeSha bs2 - (size', bs4) <- takeNetword bs3 - (typeW, bs5) <- B.uncons bs4 - ft <- - case typeW of - 78 -> Just FTNormal -- 'N' - 88 -> Just FTExecutable -- 'X' - _ -> Nothing - let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft - loop (Map.insert sfp entry m) bs5 - - takeNetstring bs1 = do - (size', bs2) <- takeNetword bs1 - guard $ B.length bs2 >= size' - Just $ B.splitAt size' bs2 - - takeSha bs = do - let (x, y) = B.splitAt 32 bs - x' <- either (const Nothing) Just (SHA256.fromRaw x) - Just (x', y) - - takeNetword = - go 0 - where - go !accum bs = do - (next, rest) <- B.uncons bs - if - | next == 58 -> pure (accum, rest) -- ':' - | next >= 48 && next <= 57 -> - go - (accum * 10 + fromIntegral (next - 48)) - rest - | otherwise -> Nothing - - {- -data PackageTarball = PackageTarball - { ptBlob :: !BlobKey - -- ^ Contains the tarball itself - , ptCabal :: !BlobKey - -- ^ Contains the cabal file contents - , ptSubdir :: !FilePath - -- ^ Subdir containing the files we want for this package. - -- - -- There must be precisely one file with a @.cabal@ file extension - -- located there. Thanks to Hackage revisions, its contents will be - -- overwritten by the value of @ptCabal@. - } - deriving Show - -} - --- | This is almost a copy of Cabal's parser for package identifiers, --- the main difference is in the fact that Stack requires version to be --- present while Cabal uses "null version" as a default value --- --- @since 0.1.0.0 -parsePackageIdentifier :: String -> Maybe PackageIdentifier -parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) - -packageIdentifierParsec :: ParsecParser PackageIdentifier -packageIdentifierParsec = do - ident@(PackageIdentifier _ v) <- parsec - - -- version is a required component of a package identifier for Stack - guard (v /= nullVersion) - - pure ident - --- | Parse a package name from a 'String'. --- --- @since 0.1.0.0 -parsePackageName :: String -> Maybe PackageName -parsePackageName = Distribution.Text.simpleParse - --- | Parse a package name from a 'String' throwing on failure --- --- @since 0.1.0.0 -parsePackageNameThrowing :: MonadThrow m => String -> m PackageName -parsePackageNameThrowing str = - case parsePackageName str of - Nothing -> throwM $ PackageNameParseFail $ T.pack str - Just pn -> pure pn - --- | Parse a version from a 'String'. --- --- @since 0.1.0.0 -parseVersion :: String -> Maybe Version -parseVersion = Distribution.Text.simpleParse - --- | Parse a package version from a 'String' throwing on failure --- --- @since 0.1.0.0 -parseVersionThrowing :: MonadThrow m => String -> m Version -parseVersionThrowing str = - case parseVersion str of - Nothing -> throwM $ PackageVersionParseFail $ T.pack str - Just v -> pure v - --- | Parse a version range from a 'String'. --- --- @since 0.1.0.0 -parseVersionRange :: String -> Maybe VersionRange -parseVersionRange = Distribution.Text.simpleParse - --- | Parse a module name from a 'String'. --- --- @since 0.1.0.0 -parseModuleName :: String -> Maybe ModuleName -parseModuleName = Distribution.Text.simpleParse - --- | Parse a flag name from a 'String'. --- --- @since 0.1.0.0 -parseFlagName :: String -> Maybe FlagName -parseFlagName = Distribution.Text.simpleParse - --- | Render a package name as a 'String'. --- --- @since 0.1.0.0 -packageNameString :: PackageName -> String -packageNameString = unPackageName - --- | Render a package identifier as a 'String'. --- --- @since 0.1.0.0 -packageIdentifierString :: PackageIdentifier -> String -packageIdentifierString = Distribution.Text.display - --- | Render a version as a 'String'. --- --- @since 0.1.0.0 -versionString :: Version -> String -versionString = Distribution.Text.display - --- | Render a flag name as a 'String'. --- --- @since 0.1.0.0 -flagNameString :: FlagName -> String -flagNameString = unFlagName - --- | Render a module name as a 'String'. --- --- @since 0.1.0.0 -moduleNameString :: ModuleName -> String -moduleNameString = Distribution.Text.display - -data OptionalSubdirs - = OSSubdirs !(NonEmpty Text) - | OSPackageMetadata !Text !RawPackageMetadata - -- ^ subdirectory and package metadata - deriving (Show, Eq, Generic) -instance NFData OptionalSubdirs - --- | Metadata provided by a config file for archives and repos. This --- information can be used for optimized lookups of information like --- package identifiers, or for validating that the user configuration --- has the expected information. --- --- @since 0.1.0.0 -data RawPackageMetadata = RawPackageMetadata - { rpmName :: !(Maybe PackageName) - -- ^ Package name in the cabal file - -- - -- @since 0.1.0.0 - , rpmVersion :: !(Maybe Version) - -- ^ Package version in the cabal file - -- - -- @since 0.1.0.0 - , rpmTreeKey :: !(Maybe TreeKey) - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) -instance NFData RawPackageMetadata - -instance Display RawPackageMetadata where - display rpm = fold $ intersperse ", " $ catMaybes - [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm - , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm - , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm - ] - --- | Exact metadata specifying concrete package --- --- @since 0.1.0.0 -data PackageMetadata = PackageMetadata - { pmIdent :: !PackageIdentifier - -- ^ Package identifier in the cabal file - -- - -- @since 0.1.0.0 - , pmTreeKey :: !TreeKey - -- ^ Tree key of the loaded up package - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Ord, Generic, Typeable) --- i PackageMetadata -instance NFData PackageMetadata - -instance Display PackageMetadata where - display pm = fold $ intersperse ", " $ - [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) - , "tree == " <> display (pmTreeKey pm) - ] - -parsePackageMetadata :: Object -> WarningParser PackageMetadata -parsePackageMetadata o = do - _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" - pantryTree :: BlobKey <- o ..: "pantry-tree" - CabalString pkgName <- o ..: "name" - CabalString pkgVersion <- o ..: "version" - let pmTreeKey = TreeKey pantryTree - pmIdent = PackageIdentifier {..} - pure PackageMetadata {..} - - --- | Conver package metadata to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawPM :: PackageMetadata -> RawPackageMetadata -toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) - where - PackageIdentifier name version = pmIdent pm - --- | File path relative to the configuration file it was parsed from --- --- @since 0.1.0.0 -newtype RelFilePath = RelFilePath Text - deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) - --- | Location that an archive is stored at --- --- @since 0.1.0.0 -data ArchiveLocation - = ALUrl !Text - -- ^ Archive stored at an HTTP(S) URL - -- - -- @since 0.1.0.0 - | ALFilePath !(ResolvedPath File) - -- ^ Archive stored at a local file path - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic, Typeable) -instance NFData ArchiveLocation - -instance Display ArchiveLocation where - display (ALUrl url) = display url - display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved - -parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) -parseArchiveLocationObject o = - ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|> - ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) <|> - ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) <|> - ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) - -parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) -parseArchiveLocationText t = - case validateUrl t of - Left e1 -> - case validateFilePath t of - Left e2 -> Left $ T.unlines - [ "Invalid archive location, neither a URL nor a file path" - , " URL error: " <> e1 - , " File path error: " <> e2 - ] - Right x -> Right x - Right x -> Right x - -validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) -validateUrl t = - case parseRequest $ T.unpack t of - Left _ -> Left $ "Could not parse URL: " <> t - Right _ -> pure $ pure $ ALUrl t - -validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) -validateFilePath t = - if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") - then pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir $ T.unpack t - pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' - else Left $ "Does not have an archive file extension: " <> t - -instance ToJSON RawPackageLocation where - toJSON (RPLImmutable rpli) = toJSON rpli - toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where - parseJSON v = - ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> - ((noJSONWarnings . mkMutable) <$> parseJSON v) - where - mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) - mkMutable t = Unresolved $ \mdir -> do - case mdir of - Nothing -> throwIO $ MutablePackageLocationFromUrl t - Just dir -> do - abs' <- resolveDir dir $ T.unpack t - pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' - -instance ToJSON RawPackageLocationImmutable where - toJSON (RPLIHackage pir mtree) = object $ concat - [ ["hackage" .= pir] - , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - ] - toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat - [ case loc of - ALUrl url -> ["url" .= url] - ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] - , maybe [] (\sha -> ["sha256" .= sha]) msha - , maybe [] (\size' -> ["size" .= size']) msize - , if T.null subdir then [] else ["subdir" .= subdir] - , rpmToPairs rpm - ] - toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat - [ [ urlKey .= url - , "commit" .= commit - ] - , if T.null subdir then [] else ["subdir" .= subdir] - , rpmToPairs rpm - ] - where - urlKey = - case typ of - RepoGit -> "git" - RepoHg -> "hg" - -rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] -rpmToPairs (RawPackageMetadata mname mversion mtree) = concat - [ maybe [] (\name -> ["name" .= CabalString name]) mname - , maybe [] (\version -> ["version" .= CabalString version]) mversion - , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree - ] - -instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where - parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) - where - repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) - repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do - pm <- parsePackageMetadata o - repoSubdir <- o ..:? "subdir" ..!= "" - repoCommit <- o ..: "commit" - (repoType, repoUrl) <- - (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> - (o ..: "hg" >>= \url -> pure (RepoHg, url)) - pure $ pure $ PLIRepo Repo {..} pm - - archiveObject = - withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do - pm <- parsePackageMetadata o - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..:? "subdir" ..!= "" - pure $ Unresolved $ \mdir -> do - archiveLocation <- mkArchiveLocation mdir - pure $ PLIArchive Archive {..} pm - - hackageObject = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do - treeKey <- o ..: "pantry-tree" - htxt <- o ..: "hackage" - case parseHackageText htxt of - Left e -> fail $ show e - Right (pkgIdentifier, blobKey) -> - pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) - - github value = - withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do - pm <- parsePackageMetadata o - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - let archiveLocation = ALUrl $ T.concat - [ "https://github.com/" - , ghRepo - , "/archive/" - , commit - , ".tar.gz" - ] - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..:? "subdir" ..!= "" - pure $ pure $ PLIArchive Archive {..} pm) value - -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where - parseJSON v - = http v - <|> hackageText v - <|> hackageObject v - <|> repo v - <|> archiveObject v - <|> github v - <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) - where - http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> - case parseArchiveLocationText t of - Left _ -> fail $ "Invalid archive location: " ++ T.unpack t - Right (Unresolved mkArchiveLocation) -> - pure $ noJSONWarnings $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - let raHash = Nothing - raSize = Nothing - raSubdir = T.empty - pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty - - hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> - case parsePackageIdentifierRevision t of - Left e -> fail $ show e - Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing - - hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage - <$> o ..: "hackage" - <*> o ..:? "pantry-tree") - - optionalSubdirs :: Object -> WarningParser OptionalSubdirs - optionalSubdirs o = - -- if subdirs exists, it needs to be valid - case HM.lookup "subdirs" o of - Just v' -> do - tellJSONField "subdirs" - subdirs <- lift $ parseJSON v' - case NE.nonEmpty subdirs of - Nothing -> fail "Invalid empty subdirs" - Just x -> pure $ OSSubdirs x - Nothing -> OSPackageMetadata - <$> o ..:? "subdir" ..!= T.empty - <*> (rawPackageMetadataHelper - <$> (fmap unCabalString <$> (o ..:? "name")) - <*> (fmap unCabalString <$> (o ..:? "version")) - <*> o ..:? "pantry-tree" - <*> o ..:? "cabal-file") - - rawPackageMetadataHelper - :: Maybe PackageName - -> Maybe Version - -> Maybe TreeKey - -> Maybe BlobKey - -> RawPackageMetadata - rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = - RawPackageMetadata name version pantryTree - - repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do - (repoType, repoUrl) <- - ((RepoGit, ) <$> o ..: "git") <|> - ((RepoHg, ) <$> o ..: "hg") - repoCommit <- o ..: "commit" - os <- optionalSubdirs o - pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) - - archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ Unresolved $ \mdir -> do - raLocation <- mkArchiveLocation mdir - pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - - github = withObjectWarnings "PLArchive:github" $ \o -> do - GitHubRepo ghRepo <- o ..: "github" - commit <- o ..: "commit" - let raLocation = ALUrl $ T.concat - [ "https://github.com/" - , ghRepo - , "/archive/" - , commit - , ".tar.gz" - ] - raHash <- o ..:? "sha256" - raSize <- o ..:? "size" - os <- optionalSubdirs o - pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - --- | Returns pairs of subdirectory and 'PackageMetadata'. -osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) -osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs -osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) - -rpmEmpty :: RawPackageMetadata -rpmEmpty = RawPackageMetadata Nothing Nothing Nothing - --- | Newtype wrapper for easier JSON integration with Cabal types. --- --- @since 0.1.0.0 -newtype CabalString a = CabalString { unCabalString :: a } - deriving (Show, Eq, Ord, Typeable) - --- I'd like to use coerce here, but can't due to roles. unsafeCoerce --- could work, but let's avoid unsafe code. - --- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' --- instance. --- --- @since 0.1.0.0 -toCabalStringMap :: Map a v -> Map (CabalString a) v -toCabalStringMap = Map.mapKeysMonotonic CabalString - --- | Unwrap the 'CabalString' from the keys in a 'Map' to use a --- 'FromJSON' instance. --- --- @since 0.1.0.0 -unCabalStringMap :: Map (CabalString a) v -> Map a v -unCabalStringMap = Map.mapKeysMonotonic unCabalString - -instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where - toJSON = toJSON . Distribution.Text.display . unCabalString -instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where - toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString - -instance forall a. IsCabalString a => FromJSON (CabalString a) where - parseJSON = withText name $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) -instance forall a. IsCabalString a => FromJSONKey (CabalString a) where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case cabalStringParser $ T.unpack t of - Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t - Just x -> pure $ CabalString x - where - name = cabalStringName (Nothing :: Maybe a) - -class IsCabalString a where - cabalStringName :: proxy a -> String - cabalStringParser :: String -> Maybe a -instance IsCabalString PackageName where - cabalStringName _ = "package name" - cabalStringParser = parsePackageName -instance IsCabalString Version where - cabalStringName _ = "version" - cabalStringParser = parseVersion -instance IsCabalString VersionRange where - cabalStringName _ = "version range" - cabalStringParser = parseVersionRange -instance IsCabalString PackageIdentifier where - cabalStringName _ = "package identifier" - cabalStringParser = parsePackageIdentifier -instance IsCabalString FlagName where - cabalStringName _ = "flag name" - cabalStringParser = parseFlagName - --- | What to use for running hpack --- --- @since 0.1.0.0 -data HpackExecutable - = HpackBundled - -- ^ Compiled in library - | HpackCommand !FilePath - -- ^ Executable at the provided path - deriving (Show, Read, Eq, Ord) - - --- | Which compiler a snapshot wants to use. The build tool may elect --- to do some fuzzy matching of versions (e.g., allowing different --- patch versions). --- --- @since 0.1.0.0 -data WantedCompiler - = WCGhc !Version - | WCGhcGit !Text !Text - | WCGhcjs - !Version - !Version - -- ^ GHCJS version followed by GHC version - deriving (Show, Eq, Ord, Generic) - -instance NFData WantedCompiler -instance Display WantedCompiler where - display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) - display (WCGhcjs vghcjs vghc) = - "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) - display (WCGhcGit commit flavour) = - "ghc-git-" <> display commit <> "-" <> display flavour -instance ToJSON WantedCompiler where - toJSON = toJSON . utf8BuilderToText . display -instance FromJSON WantedCompiler where - parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler -instance FromJSONKey WantedCompiler where - fromJSONKey = - FromJSONKeyTextParser $ \t -> - case parseWantedCompiler t of - Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e - Right x -> pure x - --- | Parse a 'Text' into a 'WantedCompiler' value. --- --- @since 0.1.0.0 -parseWantedCompiler :: Text -> Either PantryException WantedCompiler -parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ - case T.stripPrefix "ghcjs-" t0 of - Just t1 -> parseGhcjs t1 - Nothing -> case T.stripPrefix "ghc-git-" t0 of - Just t1 -> parseGhcGit t1 - Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc - where - parseGhcjs t1 = do - let (ghcjsVT, t2) = T.break (== '_') t1 - ghcjsV <- parseVersion $ T.unpack ghcjsVT - ghcVT <- T.stripPrefix "_ghc-" t2 - ghcV <- parseVersion $ T.unpack ghcVT - pure $ WCGhcjs ghcjsV ghcV - parseGhcGit t1 = do - let (commit, flavour) = T.break (== '-') t1 - pure $ WCGhcGit commit (T.drop 1 flavour) - parseGhc = fmap WCGhc . parseVersion . T.unpack - -instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where - parseJSON v = text v <|> obj v - where - text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation - - obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) - obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> - ((pure . RSLCompiler) <$> o ..: "compiler") <|> - ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> - (parseRawSnapshotLocationPath <$> o ..: "filepath") - - blobKey o = do - msha <- o ..:? "sha256" - msize <- o ..:? "size" - case (msha, msize) of - (Nothing, Nothing) -> pure Nothing - (Just sha, Just size') -> pure $ Just $ BlobKey sha size' - (Just _sha, Nothing) -> fail "You must also specify the file size" - (Nothing, Just _) -> fail "You must also specify the file's SHA256" - -instance Display SnapshotLocation where - display (SLCompiler compiler) = display compiler - display (SLUrl url blob) = display url <> " (" <> display blob <> ")" - display (SLFilePath resolved) = display (resolvedRelative resolved) - --- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. --- --- @since 0.1.0.0 -parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ - (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> - (pure <$> RSLSynonym <$> parseSnapName t0) <|> - parseGithub <|> - parseUrl - where - parseGithub = do - t1 <- T.stripPrefix "github:" t0 - let (user, t2) = T.break (== '/') t1 - t3 <- T.stripPrefix "/" t2 - let (repo, t4) = T.break (== ':') t3 - path <- T.stripPrefix ":" t4 - Just $ pure $ githubSnapshotLocation user repo path - - parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) - -parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation -parseRawSnapshotLocationPath t = - Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot t - Just dir -> do - abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) - pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' - -githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation -githubSnapshotLocation user repo path = - let url = T.concat - [ "https://raw.githubusercontent.com/" - , user - , "/" - , repo - , "/master/" - , path - ] - in RSLUrl url Nothing - -defUser :: Text -defUser = "commercialhaskell" - -defRepo :: Text -defRepo = "stackage-snapshots" - --- | Default location of snapshot synonyms --- , i.e. commercialhaskell's GitHub repository. --- --- @since 0.5.0.0 -defaultSnapshotLocation - :: SnapName - -> RawSnapshotLocation -defaultSnapshotLocation (LTS x y) = - githubSnapshotLocation defUser defRepo $ - utf8BuilderToText $ - "lts/" <> display x <> "/" <> display y <> ".yaml" -defaultSnapshotLocation (Nightly date) = - githubSnapshotLocation defUser defRepo $ - utf8BuilderToText $ - "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" - where - (year, month, day) = toGregorian date - --- | A snapshot synonym. --- It is expanded according to the field 'snapshotLocation' --- of a 'PantryConfig'. --- --- @ since 0.5.0.0 -data SnapName - -- | LTS Haskell snapshot, - -- displayed as @"lts-maj.min"@. - -- - -- @since 0.5.0.0 - = LTS - !Int -- ^ Major version - !Int -- ^ Minor version - -- | Stackage Nightly snapshot, - -- displayed as @"nighly-YYYY-MM-DD"@. - -- - -- @since 0.5.0.0 - | Nightly !Day - deriving (Eq, Ord, Generic) - -instance NFData SnapName - -instance Display SnapName where - display (LTS x y) = "lts-" <> display x <> "." <> display y - display (Nightly date) = "nightly-" <> displayShow date - -instance Show SnapName where - show = T.unpack . utf8BuilderToText . display - -instance ToJSON SnapName where - toJSON syn = String $ utf8BuilderToText $ display syn - --- | Parse the short representation of a 'SnapName'. --- --- @since 0.5.0.0 -parseSnapName :: MonadThrow m => Text -> m SnapName -parseSnapName t0 = - case lts <|> nightly of - Nothing -> throwM $ ParseSnapNameException t0 - Just sn -> return sn - where - lts = do - t1 <- T.stripPrefix "lts-" t0 - Right (x, t2) <- Just $ decimal t1 - t3 <- T.stripPrefix "." t2 - Right (y, "") <- Just $ decimal t3 - return $ LTS x y - nightly = do - t1 <- T.stripPrefix "nightly-" t0 - Nightly <$> readMaybe (T.unpack t1) - --- | Where to load a snapshot from in raw form --- (RSUrl could have a missing BlobKey) --- --- @since 0.1.0.0 -data RawSnapshotLocation - = RSLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler - -- with its shipped packages. - -- - -- @since 0.1.0.0 - | RSLUrl !Text !(Maybe BlobKey) - -- ^ Download the snapshot from the given URL. The optional - -- 'BlobKey' is used for reproducibility. - -- - -- @since 0.1.0.0 - | RSLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - | RSLSynonym !SnapName - -- ^ Snapshot synonym (LTS/Nightly). - -- - -- @since 0.5.0.0 - deriving (Show, Eq, Ord, Generic) - -instance NFData RawSnapshotLocation - -instance Display RawSnapshotLocation where - display (RSLCompiler compiler) = display compiler - display (RSLUrl url Nothing) = display url - display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" - display (RSLFilePath resolved) = display (resolvedRelative resolved) - display (RSLSynonym syn) = display syn - - -instance ToJSON RawSnapshotLocation where - toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] - toJSON (RSLUrl url mblob) = object - $ "url" .= url - : maybe [] blobKeyPairs mblob - toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] - toJSON (RSLSynonym syn) = toJSON syn - --- | Where to load a snapshot from. --- --- @since 0.1.0.0 -data SnapshotLocation - = SLCompiler !WantedCompiler - -- ^ Don't use an actual snapshot, just a version of the compiler - -- with its shipped packages. - -- - -- @since 0.1.0.0 - | SLUrl !Text !BlobKey - -- ^ Download the snapshot from the given URL. The optional - -- 'BlobKey' is used for reproducibility. - -- - -- @since 0.1.0.0 - | SLFilePath !(ResolvedPath File) - -- ^ Snapshot at a local file path. - -- - -- @since 0.1.0.0 - deriving (Show, Eq, Ord, Generic) -instance NFData SnapshotLocation - -instance ToJSON SnapshotLocation where - toJSON sl = toJSON (toRawSL sl) - -instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where - parseJSON v = file v <|> url v <|> compiler v - where - file = withObjectWarnings "SLFilepath" $ \o -> do - ufp <- o ..: "filepath" - pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot ufp - Just dir -> do - absolute <- resolveFile dir (T.unpack ufp) - let fp = ResolvedPath (RelFilePath ufp) absolute - pure $ SLFilePath fp - url = withObjectWarnings "SLUrl" $ \o -> do - url' <- o ..: "url" - sha <- o ..: "sha256" - size <- o ..: "size" - pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) - compiler = withObjectWarnings "SLCompiler" $ \o -> do - c <- o ..: "compiler" - pure $ Unresolved $ \_ -> pure $ SLCompiler c - --- | Convert snapshot location to its "raw" equivalent. --- --- @since 0.1.0.0 -toRawSL :: SnapshotLocation -> RawSnapshotLocation -toRawSL (SLCompiler c) = RSLCompiler c -toRawSL (SLUrl url blob) = RSLUrl url (Just blob) -toRawSL (SLFilePath fp) = RSLFilePath fp - --- | A flattened representation of all the layers in a snapshot. --- --- @since 0.1.0.0 -data RawSnapshot = RawSnapshot - { rsCompiler :: !WantedCompiler - -- ^ The compiler wanted for this snapshot. - , rsPackages :: !(Map PackageName RawSnapshotPackage) - -- ^ Packages available in this snapshot for installation. This will be - -- applied on top of any globally available packages. - , rsDrop :: !(Set PackageName) - -- ^ Global packages that should be dropped/ignored. - } - --- | A flattened representation of all the layers in a snapshot. --- --- @since 0.1.0.0 -data Snapshot = Snapshot - { snapshotCompiler :: !WantedCompiler - -- ^ The compiler wanted for this snapshot. - , snapshotPackages :: !(Map PackageName SnapshotPackage) - -- ^ Packages available in this snapshot for installation. This will be - -- applied on top of any globally available packages. - , snapshotDrop :: !(Set PackageName) - -- ^ Global packages that should be dropped/ignored. - } - --- | Settings for a package found in a snapshot. --- --- @since 0.1.0.0 -data RawSnapshotPackage = RawSnapshotPackage - { rspLocation :: !RawPackageLocationImmutable - -- ^ Where to get the package from - , rspFlags :: !(Map FlagName Bool) - -- ^ Same as 'slFlags' - , rspHidden :: !Bool - -- ^ Same as 'slHidden' - , rspGhcOptions :: ![Text] - -- ^ Same as 'slGhcOptions' - } - --- | Settings for a package found in a snapshot. --- --- @since 0.1.0.0 -data SnapshotPackage = SnapshotPackage - { spLocation :: !PackageLocationImmutable - -- ^ Where to get the package from - , spFlags :: !(Map FlagName Bool) - -- ^ Same as 'slFlags' - , spHidden :: !Bool - -- ^ Same as 'slHidden' - , spGhcOptions :: ![Text] - -- ^ Same as 'slGhcOptions' - } - deriving Show - --- | A single layer of a snapshot, i.e. a specific YAML configuration file. --- --- @since 0.1.0.0 -data RawSnapshotLayer = RawSnapshotLayer - { rslParent :: !RawSnapshotLocation - -- ^ The sl to extend from. This is either a specific - -- compiler, or a @SnapshotLocation@ which gives us more information - -- (like packages). Ultimately, we'll end up with a - -- @CompilerVersion@. - -- - -- @since 0.1.0.0 - , rslCompiler :: !(Maybe WantedCompiler) - -- ^ Override the compiler specified in 'slParent'. Must be - -- 'Nothing' if using 'SLCompiler'. - -- - -- @since 0.1.0.0 - , rslLocations :: ![RawPackageLocationImmutable] - -- ^ Where to grab all of the packages from. - -- - -- @since 0.1.0.0 - , rslDropPackages :: !(Set PackageName) - -- ^ Packages present in the parent which should not be included - -- here. - -- - -- @since 0.1.0.0 - , rslFlags :: !(Map PackageName (Map FlagName Bool)) - -- ^ Flag values to override from the defaults - -- - -- @since 0.1.0.0 - , rslHidden :: !(Map PackageName Bool) - -- ^ Packages which should be hidden when registering. This will - -- affect, for example, the import parser in the script - -- command. We use a 'Map' instead of just a 'Set' to allow - -- overriding the hidden settings in a parent sl. - -- - -- @since 0.1.0.0 - , rslGhcOptions :: !(Map PackageName [Text]) - -- ^ GHC options per package - -- - -- @since 0.1.0.0 - , rslPublishTime :: !(Maybe UTCTime) - -- ^ See 'slPublishTime' - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Generic) - -instance NFData RawSnapshotLayer - -instance ToJSON RawSnapshotLayer where - toJSON rsnap = object $ concat - [ ["resolver" .= rslParent rsnap] - , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) - , ["packages" .= rslLocations rsnap] - , if Set.null (rslDropPackages rsnap) - then [] - else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] - , if Map.null (rslFlags rsnap) - then [] - else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] - , if Map.null (rslHidden rsnap) - then [] - else ["hidden" .= toCabalStringMap (rslHidden rsnap)] - , if Map.null (rslGhcOptions rsnap) - then [] - else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] - , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) - ] - -instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where - parseJSON = withObjectWarnings "Snapshot" $ \o -> do - _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format - mcompiler <- o ..:? "compiler" - mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] - unresolvedSnapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) - (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do - sl <- usl mdir - case (sl, mcompiler) of - (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 - _ -> pure (sl, mcompiler) - - unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) - rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) - rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) - rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) - rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) - rslPublishTime <- o ..:? "publish-time" - pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) - <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) - <*> unresolvedSnapshotParent - --- | A single layer of a snapshot, i.e. a specific YAML configuration file. --- --- @since 0.1.0.0 -data SnapshotLayer = SnapshotLayer - { slParent :: !SnapshotLocation - -- ^ The sl to extend from. This is either a specific - -- compiler, or a @SnapshotLocation@ which gives us more information - -- (like packages). Ultimately, we'll end up with a - -- @CompilerVersion@. - -- - -- @since 0.1.0.0 - , slCompiler :: !(Maybe WantedCompiler) - -- ^ Override the compiler specified in 'slParent'. Must be - -- 'Nothing' if using 'SLCompiler'. - -- - -- @since 0.1.0.0 - , slLocations :: ![PackageLocationImmutable] - -- ^ Where to grab all of the packages from. - -- - -- @since 0.1.0.0 - , slDropPackages :: !(Set PackageName) - -- ^ Packages present in the parent which should not be included - -- here. - -- - -- @since 0.1.0.0 - , slFlags :: !(Map PackageName (Map FlagName Bool)) - -- ^ Flag values to override from the defaults - -- - -- @since 0.1.0.0 - , slHidden :: !(Map PackageName Bool) - -- ^ Packages which should be hidden when registering. This will - -- affect, for example, the import parser in the script - -- command. We use a 'Map' instead of just a 'Set' to allow - -- overriding the hidden settings in a parent sl. - -- - -- @since 0.1.0.0 - , slGhcOptions :: !(Map PackageName [Text]) - -- ^ GHC options per package - -- - -- @since 0.1.0.0 - , slPublishTime :: !(Maybe UTCTime) - -- ^ Publication timestamp for this snapshot. This field is optional, and - -- is for informational purposes only. - -- - -- @since 0.1.0.0 - } - deriving (Show, Eq, Generic) - -instance ToJSON SnapshotLayer where - toJSON snap = object $ concat - [ ["resolver" .= slParent snap] - , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) - , ["packages" .= slLocations snap] - , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] - , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] - , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] - , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] - , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) - ] - --- | Convert snapshot layer into its "raw" equivalent. --- --- @since 0.1.0.0 -toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer -toRawSnapshotLayer sl = RawSnapshotLayer - { rslParent = toRawSL (slParent sl) - , rslCompiler = slCompiler sl - , rslLocations = map toRawPLI (slLocations sl) - , rslDropPackages = slDropPackages sl - , rslFlags = slFlags sl - , rslHidden = slHidden sl - , rslGhcOptions = slGhcOptions sl - , rslPublishTime = slPublishTime sl - } - --- | An arbitrary hash for a snapshot, used for finding module names --- in a snapshot. Mostly intended for Stack's usage. --- --- @since 0.1.0.0 -newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} - deriving (Show) - --- | Get the path to the global hints cache file -getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) -getGlobalHintsFile = do - root <- view $ pantryConfigL.to pcRootDir - globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" - pure $ root globalHintsRelFile - --- | Creates BlobKey for an input ByteString --- --- @since 0.1.0.0 -bsToBlobKey :: ByteString -> BlobKey -bsToBlobKey bs = - BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) - --- | Warn if the package uses 'PCHpack'. --- --- @since 0.4.0.0 -warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () -warnMissingCabalFile loc = - logWarn $ - "DEPRECATED: The package at " <> display loc <> - " does not include a cabal file.\n" <> - "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> - "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> - "Support for this workflow will be removed in the future.\n" +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +module Pantry.Types + ( PantryConfig (..) + , HackageSecurityConfig (..) + , Storage (..) + , HasPantryConfig (..) + , BlobKey (..) + , PackageName + , Version + , PackageIdentifier (..) + , Revision (..) + , ModuleName + , CabalFileInfo (..) + , PrintWarnings (..) + , PackageNameP (..) + , VersionP (..) + , ModuleNameP (..) + , PackageIdentifierRevision (..) + , pirForHash + , FileType (..) + , BuildFile (..) + , FileSize (..) + , TreeEntry (..) + , SafeFilePath + , unSafeFilePath + , mkSafeFilePath + , safeFilePathToPath + , hpackSafeFilePath + , TreeKey (..) + , Tree (..) + , renderTree + , parseTree + , parseTreeM + , SHA256 + , Unresolved + , resolvePaths + , Package (..) + , PackageCabal (..) + , PHpack (..) + -- , PackageTarball (..) + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + , toRawPLI + , RawArchive (..) + , Archive (..) + , toRawArchive + , Repo (..) + , AggregateRepo (..) + , SimpleRepo (..) + , toAggregateRepos + , rToSimpleRepo + , arToSimpleRepo + , RepoType (..) + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , OptionalSubdirs (..) + , ArchiveLocation (..) + , RelFilePath (..) + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , parsePackageIdentifierRevision + , Mismatch (..) + , PantryException (..) + , FuzzyResults (..) + , ResolvedPath (..) + , HpackExecutable (..) + , WantedCompiler (..) + --, resolveSnapshotLocation + , snapshotLocation + , defaultSnapshotLocation + , SnapName (..) + , parseSnapName + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , parseHackageText + , parseRawSnapshotLocation + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , parseWantedCompiler + , RawPackageMetadata (..) + , PackageMetadata (..) + , toRawPM + , cabalFileName + , SnapshotCacheHash (..) + , getGlobalHintsFile + , bsToBlobKey + , warnMissingCabalFile + , connRDBMS + ) where + +import RIO +import qualified Data.Conduit.Tar as Tar +import qualified RIO.Text as T +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.List (intersperse, groupBy) +import RIO.Time (toGregorian, Day, UTCTime) +import qualified RIO.Map as Map +import qualified Data.Map.Strict as Map (mapKeysMonotonic) +import qualified RIO.Set as Set +import Data.Aeson.Types (toJSONKeyText, Parser) +import Pantry.Internal.AesonExtended +import Data.Aeson.Encoding.Internal (unsafeToEncoding) +import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) +import Database.Persist +import Database.Persist.Sql +import Pantry.SHA256 (SHA256) +import qualified Pantry.SHA256 as SHA256 +import qualified Distribution.Compat.CharParsing as Parse +import Distribution.CabalSpecVersion (cabalSpecLatest) +#if MIN_VERSION_Cabal(3,4,0) +import Distribution.CabalSpecVersion (cabalSpecToVersionDigits) +#else +import Distribution.CabalSpecVersion (CabalSpecVersion (..)) +#endif +import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser) +import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) +import Distribution.Types.VersionRange (VersionRange) +import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import qualified Distribution.Pretty +import qualified Distribution.Text +import qualified Hpack.Config as Hpack +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Version (Version, mkVersion, nullVersion) +import Network.HTTP.Client (parseRequest) +import Network.HTTP.Types (Status, statusCode) +import Data.Text.Read (decimal) +import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) +import Path.IO (resolveFile, resolveDir) +import qualified Data.List.NonEmpty as NE +import Casa.Client (CasaRepoPrefix) + +#if MIN_VERSION_persistent(2, 13, 0) +import Database.Persist.SqlBackend.Internal (connRDBMS) +#endif + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as HM +import qualified Data.Aeson.Key + +type AesonKey = Data.Aeson.Key.Key +#else +import qualified RIO.HashMap as HM + +type AesonKey = Text +#endif + +-- | Parsed tree with more information on the Haskell package it contains. +-- +-- @since 0.1.0.0 +data Package = Package + { packageTreeKey :: !TreeKey + -- ^ The 'TreeKey' containing this package. + -- + -- This is a hash of the binary representation of 'packageTree'. + -- + -- @since 0.1.0.0 + , packageTree :: !Tree + -- ^ The 'Tree' containing this package. + -- + -- @since 0.1.0.0 + , packageCabalEntry :: !PackageCabal + -- ^ Information on the cabal file inside this package. + -- + -- @since 0.1.0.0 + , packageIdent :: !PackageIdentifier + -- ^ The package name and version in this package. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord) + +data PHpack = PHpack + { + phOriginal :: !TreeEntry, -- ^ Original hpack file + phGenerated :: !TreeEntry, -- ^ Generated Cabal file + phVersion :: !Version -- ^ Version of Hpack used + } deriving (Show, Eq, Ord) + +data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file + | PCHpack !PHpack + deriving (Show, Eq, Ord) + +cabalFileName :: PackageName -> SafeFilePath +cabalFileName name = + case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of + Nothing -> error $ "cabalFileName: failed for " ++ show name + Just sfp -> sfp + +-- | The revision number of a package from Hackage, counting upwards +-- from 0 (the original cabal file). +-- +-- See caveats on 'CFIRevision'. +-- +-- @since 0.1.0.0 +newtype Revision = Revision Word + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) + +-- | Represents a SQL database connection. This used to be a newtype +-- wrapper around a connection pool. However, when investigating +-- , it +-- appeared that holding a pool resulted in overly long write locks +-- being held on the database. As a result, we now abstract away +-- whether a pool is used, and the default implementation in +-- "Pantry.Storage" does not use a pool. +data Storage = Storage + { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a + , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a + } + +-- | Configuration value used by the entire pantry package. Create one +-- using @withPantryConfig@. See also @PantryApp@ for a convenience +-- approach to using pantry. +-- +-- @since 0.1.0.0 +data PantryConfig = PantryConfig + { pcHackageSecurity :: !HackageSecurityConfig + , pcHpackExecutable :: !HpackExecutable + , pcRootDir :: !(Path Abs Dir) + , pcStorage :: !Storage + , pcUpdateRef :: !(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@. + , pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) + -- ^ Cache of previously parsed cabal files, to save on slow parsing time. + , pcParsedCabalFilesMutable :: + !(IORef + (Map + (Path Abs Dir) + (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File) + ) + ) + -- ^ Cache for mutable packages. We want to allow for an optimization: + -- deferring parsing of the 'GenericPackageDescription' until its actually + -- needed. Therefore, we keep the filepath and the 'PackageName' derived from + -- that filepath. When the @IO GenericPackageDescription@ is run, it will + -- ensure that the @PackageName@ matches the value inside the cabal file, and + -- print out any warnings that still need to be printed. + , pcConnectionCount :: !Int + -- ^ concurrently open downloads + , pcCasaRepoPrefix :: !CasaRepoPrefix + -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@ + , pcCasaMaxPerRequest :: !Int + -- ^ Maximum blobs sent per pull request. + , pcSnapshotLocation :: SnapName -> RawSnapshotLocation + -- ^ The location of snapshot synonyms + } + +-- | Get the location of a snapshot synonym from the 'PantryConfig'. +-- +-- @since 0.5.0.0 +snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation +snapshotLocation name = do + loc <- view $ pantryConfigL.to pcSnapshotLocation + pure $ loc name + +-- | Should we print warnings when loading a cabal file? +-- +-- @since 0.1.0.0 +data PrintWarnings = YesPrintWarnings | NoPrintWarnings + +-- | Wraps a value which potentially contains relative paths. Needs to +-- be provided with a base directory to resolve these paths. +-- +-- Unwrap this using 'resolvePaths'. +-- +-- @since 0.1.0.0 +newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) + deriving Functor +instance Applicative Unresolved where + pure = Unresolved . const . pure + Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir + +-- | Resolve all of the file paths in an 'Unresolved' relative to the +-- given directory. +-- +-- @since 0.1.0.0 +resolvePaths + :: MonadIO m + => Maybe (Path Abs Dir) -- ^ directory to use for relative paths + -> Unresolved a + -> m a +resolvePaths mdir (Unresolved f) = liftIO (f mdir) + +-- | A combination of the relative path provided in a config file, +-- together with the resolved absolute path. +-- +-- @since 0.1.0.0 +data ResolvedPath t = ResolvedPath + { resolvedRelative :: !RelFilePath + -- ^ Original value parsed from a config file. + , resolvedAbsolute :: !(Path Abs t) + -- ^ Absolute path resolved against base directory loaded from. + } + deriving (Show, Eq, Generic, Ord) +instance NFData (ResolvedPath t) + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected +-- to change over time. Raw version doesn't include exact package +-- version (e.g. could refer to the latest revision on Hackage) +-- +-- @since 0.1.0.0 +data RawPackageLocation + = RPLImmutable !RawPackageLocationImmutable + | RPLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) +instance NFData RawPackageLocation + +-- | Location to load a package from. Can either be immutable (see +-- 'PackageLocationImmutable') or a local directory which is expected +-- to change over time. +-- +-- @since 0.1.0.0 +data PackageLocation + = PLImmutable !PackageLocationImmutable + | PLMutable !(ResolvedPath Dir) + deriving (Show, Eq, Generic) +instance NFData PackageLocation + +instance Display PackageLocation where + display (PLImmutable loc) = display loc + display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp + +-- | Convert `PackageLocation` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPL :: PackageLocation -> RawPackageLocation +toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) +toRawPL (PLMutable m) = RPLMutable m + +-- | Location for remote packages or archives assumed to be immutable. +-- as user specifies it i.e. not an exact location +-- +-- @since 0.1.0.0 +data RawPackageLocationImmutable + = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) + | RPLIArchive !RawArchive !RawPackageMetadata + | RPLIRepo !Repo !RawPackageMetadata + deriving (Show, Eq, Ord, Generic) + +instance NFData RawPackageLocationImmutable + +instance Display RawPackageLocationImmutable where + display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" + display (RPLIArchive archive _pm) = + "Archive from " <> display (raLocation archive) <> + (if T.null $ raSubdir archive + then mempty + else " in subdir " <> display (raSubdir archive)) + display (RPLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +-- | Location for remote packages or archives assumed to be immutable. +-- +-- @since 0.1.0.0 +data PackageLocationImmutable + = PLIHackage !PackageIdentifier !BlobKey !TreeKey + | PLIArchive !Archive !PackageMetadata + | PLIRepo !Repo !PackageMetadata + deriving (Generic, Show, Eq, Ord, Typeable) +instance NFData PackageLocationImmutable + +instance Display PackageLocationImmutable where + display (PLIHackage ident _cabalHash _tree) = + fromString (packageNameString $ pkgName ident) <> " (from Hackage)" + display (PLIArchive archive _pm) = + "Archive from " <> display (archiveLocation archive) <> + (if T.null $ archiveSubdir archive + then mempty + else " in subdir " <> display (archiveSubdir archive)) + display (PLIRepo repo _pm) = + "Repo from " <> display (repoUrl repo) <> + ", commit " <> display (repoCommit repo) <> + (if T.null $ repoSubdir repo + then mempty + else " in subdir " <> display (repoSubdir repo)) + +instance ToJSON PackageLocationImmutable where + toJSON = toJSON . toRawPLI + +-- | Package identifier and revision with a specified cabal file hash +-- +-- @since 0.1.0.0 +pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision +pirForHash (PackageIdentifier name ver) (BlobKey sha size') = + let cfi = CFIHash sha (Just size') + in PackageIdentifierRevision name ver cfi + +-- | Convert `PackageLocationImmutable` to its "raw" equivalent +-- +-- @since 0.1.0.0 +toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable +toRawPLI (PLIHackage ident cfKey treeKey) = RPLIHackage (pirForHash ident cfKey) (Just treeKey) +toRawPLI (PLIArchive archive pm) = RPLIArchive (toRawArchive archive) (toRawPM pm) +toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) + +-- | A raw package archive, specified by a user, could have no +-- hash and file size information. +-- +-- @since 0.1.0.0 +data RawArchive = RawArchive + { raLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , raHash :: !(Maybe SHA256) + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , raSize :: !(Maybe FileSize) + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , raSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) + +instance NFData RawArchive + +-- | A package archive, could be from a URL or a local file +-- path. Local file path archives are assumed to be unchanging +-- over time, and so are allowed in custom snapshots. +-- +-- @since 0.1.0.0 +data Archive = Archive + { archiveLocation :: !ArchiveLocation + -- ^ Location of the archive + -- + -- @since 0.1.0.0 + , archiveHash :: !SHA256 + -- ^ Cryptographic hash of the archive file + -- + -- @since 0.1.0.0 + , archiveSize :: !FileSize + -- ^ Size of the archive file + -- + -- @since 0.1.0.0 + , archiveSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Show, Eq, Ord, Typeable) +instance NFData Archive + +-- | Convert archive to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawArchive :: Archive -> RawArchive +toRawArchive archive = + RawArchive (archiveLocation archive) (Just $ archiveHash archive) + (Just $ archiveSize archive) (archiveSubdir archive) + +-- | The type of a source control repository. +-- +-- @since 0.1.0.0 +data RepoType = RepoGit | RepoHg + deriving (Generic, Show, Eq, Ord, Typeable) +instance NFData RepoType +instance PersistField RepoType where + toPersistValue RepoGit = toPersistValue (1 :: Int32) + toPersistValue RepoHg = toPersistValue (2 :: Int32) + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int32 of + 1 -> pure RepoGit + 2 -> pure RepoHg + _ -> Left $ fromString $ "Invalid RepoType: " ++ show i +instance PersistFieldSql RepoType where + sqlType _ = SqlInt32 + +-- | Information on packages stored in a source control repository. +-- +-- @since 0.1.0.0 +data Repo = Repo + { repoUrl :: !Text + -- ^ Location of the repo + -- + -- @since 0.1.0.0 + , repoCommit :: !Text + -- ^ Commit to use from the repo. It's strongly recommended to use + -- a hash instead of a tag or branch name. + -- + -- @since 0.1.0.0 + , repoType :: !RepoType + -- ^ The type of the repo + -- + -- @since 0.1.0.0 + , repoSubdir :: !Text + -- ^ Subdirectory within the archive to get the package from. + -- + -- @since 0.1.0.0 + } + deriving (Generic, Eq, Ord, Typeable) +instance NFData Repo +instance Show Repo where + show = T.unpack . utf8BuilderToText . display +instance Display Repo where + display (Repo url commit typ subdir) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit <> + (if T.null subdir + then mempty + else " in subdirectory " <> display subdir) + +rToSimpleRepo :: Repo -> SimpleRepo +rToSimpleRepo Repo {..} = SimpleRepo { sRepoUrl = repoUrl, sRepoCommit = repoCommit, sRepoType = repoType } + +data AggregateRepo = AggregateRepo + { aRepo :: !SimpleRepo + , aRepoSubdirs :: [(Text, RawPackageMetadata)] + } + deriving (Show, Generic, Eq, Ord, Typeable) + +-- | Group input repositories by non-subdir values. +toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo] +toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir + where + toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo + toAggregateRepo [] = Nothing + toAggregateRepo xs@((repo, _):_) = + Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs) + + matchRepoExclSubdir x1 x2 = + let (Repo url1 commit1 type1 _, _) = x1 + (Repo url2 commit2 type2 _, _) = x2 + in (url1, commit1, type1) == (url2, commit2, type2) + +arToSimpleRepo :: AggregateRepo -> SimpleRepo +arToSimpleRepo AggregateRepo {..} = aRepo + +-- | Repository without subdirectory information. +-- +-- @since 0.5.3 +data SimpleRepo = SimpleRepo + { sRepoUrl :: !Text + , sRepoCommit :: !Text + , sRepoType :: !RepoType + } + deriving (Show, Generic, Eq, Ord, Typeable) + +instance Display SimpleRepo where + display (SimpleRepo url commit typ) = + (case typ of + RepoGit -> "Git" + RepoHg -> "Mercurial") <> + " repo at " <> + display url <> + ", commit " <> + display commit + +-- 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\"" + +-- | Configuration for Hackage Security to securely download package +-- metadata and contents from Hackage. For most purposes, you'll want +-- to use the default Hackage settings via +-- @defaultHackageSecurityConfig@. +-- +-- /NOTE/ It's highly recommended to only use the official Hackage +-- server or a mirror. See +-- . +-- +-- @since 0.1.0.0 +data HackageSecurityConfig = HackageSecurityConfig + { hscKeyIds :: ![Text] + , hscKeyThreshold :: !Int + , hscDownloadPrefix :: !Text + , hscIgnoreExpiry :: !Bool + } + deriving Show +instance FromJSON (WithJSONWarnings HackageSecurityConfig) where + parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do + hscDownloadPrefix <- o' ..: "download-prefix" + Object o <- o' ..: "hackage-security" + hscKeyIds <- o ..: "keyids" + hscKeyThreshold <- o ..: "key-threshold" + hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True + pure HackageSecurityConfig {..} + + +-- | An environment which contains a 'PantryConfig'. +-- +-- @since 0.1.0.0 +class HasPantryConfig env where + -- | Lens to get or set the 'PantryConfig' + -- + -- @since 0.1.0.0 + pantryConfigL :: Lens' env PantryConfig + + +-- | File size in bytes +-- +-- @since 0.1.0.0 +newtype FileSize = FileSize Word + deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON) + +-- | A key for looking up a blob, which combines the SHA256 hash of +-- the contents and the file size. +-- +-- The file size may seem redundant with the hash. However, it is +-- necessary for safely downloading blobs from an untrusted +-- source. See +-- . +-- +-- @since 0.1.0.0 +data BlobKey = BlobKey !SHA256 !FileSize + deriving (Eq, Ord, Typeable, Generic) +instance NFData BlobKey + +instance Show BlobKey where + show = T.unpack . utf8BuilderToText . display +instance Display BlobKey where + display (BlobKey sha size') = display sha <> "," <> display size' + +blobKeyPairs :: BlobKey -> [(AesonKey, Value)] +blobKeyPairs (BlobKey sha size') = + [ "sha256" .= sha + , "size" .= size' + ] + +instance ToJSON BlobKey where + toJSON = object . blobKeyPairs +instance FromJSON BlobKey where + parseJSON = withObject "BlobKey" $ \o -> BlobKey + <$> o .: "sha256" + <*> o .: "size" + +newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } + deriving (Eq, Ord, Show, Read, NFData) +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP +instance PersistField PackageNameP where + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn + fromPersistValue v = do + str <- fromPersistValue v + case parsePackageName str of + Nothing -> Left $ "Invalid package name: " <> T.pack str + Just pn -> Right $ PackageNameP pn +instance PersistFieldSql PackageNameP where + sqlType _ = SqlString +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn +instance FromJSON PackageNameP where + parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (fromString . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) +instance PersistField VersionP where + toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v + fromPersistValue v = do + str <- fromPersistValue v + case parseVersion str of + Nothing -> Left $ "Invalid version number: " <> T.pack str + Just ver -> Right $ VersionP ver +instance PersistFieldSql VersionP where + sqlType _ = SqlString +instance Display VersionP where + display (VersionP v) = fromString $ versionString v +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } deriving (Eq, Ord, Show, NFData) +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP +instance PersistField ModuleNameP where + toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn + fromPersistValue v = do + str <- fromPersistValue v + case parseModuleName str of + Nothing -> Left $ "Invalid module name: " <> T.pack str + Just pn -> Right $ ModuleNameP pn +instance PersistFieldSql ModuleNameP where + sqlType _ = SqlString + +-- | How to choose a cabal file for a package from Hackage. This is to +-- work with Hackage cabal file revisions, which makes +-- @PackageIdentifier@ insufficient for specifying a package from +-- Hackage. +-- +-- @since 0.1.0.0 +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + -- + -- @since 0.1.0.0 + | CFIHash !SHA256 !(Maybe FileSize) + -- ^ Identify by contents of the cabal file itself. Only reason for + -- @Maybe@ on @FileSize@ is for compatibility with input that + -- doesn't include the file size. + -- + -- @since 0.1.0.0 + | CFIRevision !Revision + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. This relies on Hackage providing consistent + -- versioning. @CFIHash@ should be preferred wherever possible for + -- reproducibility. + -- + -- @since 0.1.0.0 + deriving (Generic, Show, Eq, Ord, Typeable) +instance NFData CabalFileInfo +instance Hashable CabalFileInfo + +instance Display CabalFileInfo where + display CFILatest = mempty + display (CFIHash hash' msize) = + "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize + display (CFIRevision rev) = "@rev:" <> display rev + +-- | A full specification for a package from Hackage, including the +-- package name, version, and how to load up the correct cabal file +-- revision. +-- +-- @since 0.1.0.0 +data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo + deriving (Generic, Eq, Ord, Typeable) +instance NFData PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = T.unpack . utf8BuilderToText . display + +instance Display PackageIdentifierRevision where + display (PackageIdentifierRevision name version cfi) = + fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure pir + +-- | Parse a hackage text. +-- +-- @since 0.1.0.0 +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = + either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ + explicitEitherParsec (hackageTextParsec <* Parse.eof) $ + T.unpack t + +hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) +hackageTextParsec = do + ident <- packageIdentifierParsec + _ <- Parse.string "@sha256:" + + shaT <- Parse.munch (/= ',') + sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT + + _ <- Parse.char ',' + size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't + pure (ident, BlobKey sha (FileSize size')) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + +-- | Parse a 'PackageIdentifierRevision' +-- +-- @since 0.1.0.0 +parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision +parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + cfi <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Just Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ Just $ FileSize size' + _ -> Nothing + pure $ CFIHash sha msize + Just ("@rev", revT) -> + case decimal revT of + Right (rev, "") -> pure $ CFIRevision $ Revision rev + _ -> Nothing + Nothing -> pure CFILatest + _ -> Nothing + pure $ PackageIdentifierRevision name version cfi + +data Mismatch a = Mismatch + { mismatchExpected :: !a + , mismatchActual :: !a + } + +-- | Things that can go wrong in pantry. Note two things: +-- +-- * Many other exception types may be thrown from underlying +-- libraries. Pantry does not attempt to wrap these underlying +-- exceptions. +-- +-- * We may add more constructors to this data type in minor version +-- bumps of pantry. This technically breaks the PVP. You should not +-- be writing pattern matches against this type that expect total +-- matching. +-- +-- @since 0.1.0.0 +data PantryException + = PackageIdentifierRevisionParseFail !Text + | InvalidCabalFile + !(Either RawPackageLocationImmutable (Path Abs File)) + !(Maybe Version) + ![PError] + ![PWarning] + | TreeWithoutCabalFile !RawPackageLocationImmutable + | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] + | MismatchedCabalName !(Path Abs File) !PackageName + | NoCabalFileFound !(Path Abs Dir) + | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] + | InvalidWantedCompiler !Text + | InvalidSnapshotLocation !(Path Abs Dir) !Text + | InvalidOverrideCompiler !WantedCompiler !WantedCompiler + | InvalidFilePathSnapshot !Text + | InvalidSnapshot !RawSnapshotLocation !SomeException + | MismatchedPackageMetadata + !RawPackageLocationImmutable + !RawPackageMetadata + !(Maybe TreeKey) + !PackageIdentifier + | Non200ResponseStatus !Status + | InvalidBlobKey !(Mismatch BlobKey) + | Couldn'tParseSnapshot !RawSnapshotLocation !String + | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName + | DownloadInvalidSHA256 !Text !(Mismatch SHA256) + | DownloadInvalidSize !Text !(Mismatch FileSize) + | DownloadTooLarge !Text !(Mismatch FileSize) + -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is + -- a lower bound on the size from the server. + | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) + | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) + | UnknownArchiveType !ArchiveLocation + | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType + | UnsupportedTarball !ArchiveLocation !Text + | NoHackageCryptographicHash !PackageIdentifier + | FailedToCloneRepo !SimpleRepo + | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey + | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata + | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) + | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults + | CannotCompleteRepoNonSHA1 !Repo + | MutablePackageLocationFromUrl !Text + | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) + | PackageNameParseFail !Text + | PackageVersionParseFail !Text + | InvalidCabalFilePath !(Path Abs File) + | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] + | MigrationFailure !Text !(Path Abs File) !SomeException + | InvalidTreeFromCasa !BlobKey !ByteString + | ParseSnapNameException !Text + + deriving Typeable +instance Exception PantryException where +instance Show PantryException where + show = T.unpack . utf8BuilderToText . display +instance Display PantryException where + display (InvalidTreeFromCasa blobKey _bs) = "Invalid tree from casa: " <> display blobKey + display (PackageIdentifierRevisionParseFail text) = + "Invalid package identifier (with optional revision): " <> + display text + display (InvalidCabalFile loc mversion errs warnings) = + "Unable to parse cabal file from package " <> + either display (fromString . toFilePath) loc <> + "\n\n" <> + foldMap + (\(PError pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + errs <> + foldMap + (\(PWarning _ pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + warnings <> + + (case mversion of + Just version + | version > cabalSpecLatestVersion -> + "\n\nThe cabal file uses the cabal specification version " <> + fromString (versionString version) <> + ", but we only support up to version " <> + fromString (versionString cabalSpecLatestVersion) <> + ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." + _ -> mempty) + display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl + display (TreeWithMultipleCabalFiles pl sfps) = + "Multiple cabal files found for " <> display pl <> ": " <> + fold (intersperse ", " (map display sfps)) + display (MismatchedCabalName fp name) = + "cabal file path " <> + fromString (toFilePath fp) <> + " does not match the package name it defines.\n" <> + "Please rename the file to: " <> + fromString (packageNameString name) <> + ".cabal\n" <> + "For more information, see: https://github.com/commercialhaskell/stack/issues/317" + display (NoCabalFileFound dir) = + "Stack looks for packages in the directories configured in\n" <> + "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> + "The current entry points to " <> + fromString (toFilePath dir) <> + ",\nbut no .cabal or package.yaml file could be found there." + display (MultipleCabalFilesFound dir files) = + "Multiple .cabal files found in directory " <> + fromString (toFilePath dir) <> + ":\n" <> + fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) + display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t + display (InvalidSnapshotLocation dir t) = + "Invalid snapshot location " <> + displayShow t <> + " relative to directory " <> + displayShow (toFilePath dir) + display (InvalidOverrideCompiler x y) = + "Specified compiler for a resolver (" <> + display x <> + "), but also specified an override compiler (" <> + display y <> + ")" + display (InvalidFilePathSnapshot t) = + "Specified snapshot as file path with " <> + displayShow t <> + ", but not reading from a local file" + display (InvalidSnapshot loc e) = + "Exception while reading snapshot from " <> + display loc <> + ":\n" <> + displayShow e + display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = + "Mismatched package metadata for " <> display loc <> + "\nFound: " <> fromString (packageIdentifierString foundIdent) <> + (case mtreeKey of + Nothing -> mempty + Just treeKey -> " with tree " <> display treeKey) <> + "\nExpected: " <> display pm + display (Non200ResponseStatus status) = + "Unexpected non-200 HTTP status code: " <> + displayShow (statusCode status) + display (InvalidBlobKey Mismatch{..}) = + "Invalid blob key found, expected: " <> + display mismatchExpected <> + ", actual: " <> + display mismatchActual + display (Couldn'tParseSnapshot sl e) = + "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e + display (WrongCabalFileName pl sfp name) = + "Wrong cabal file name for package " <> display pl <> + "\nThe cabal file is named " <> display sfp <> + ", but package name is " <> fromString (packageNameString name) <> + "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" + display (DownloadInvalidSHA256 url Mismatch {..}) = + "Mismatched SHA256 hash from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadInvalidSize url Mismatch {..}) = + "Mismatched download size from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadTooLarge url Mismatch {..}) = + "Download from " <> display url <> " was too large.\n" <> + "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> + display mismatchActual + display (LocalInvalidSHA256 path Mismatch {..}) = + "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (LocalInvalidSize path Mismatch {..}) = + "Mismatched file size from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc + display (InvalidTarFileType loc fp x) = + "Unsupported tar file type in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x + display (UnsupportedTarball loc e) = + "Unsupported tarball from " <> display loc <> ": " <> display e + display (NoHackageCryptographicHash ident) = + "No cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) + display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo + display (TreeReferencesMissingBlob loc sfp key) = + "The package " <> display loc <> + " needs blob " <> display key <> + " for file path " <> display sfp <> + ", but the blob is not available" + display (CompletePackageMetadataMismatch loc pm) = + "When completing package metadata for " <> display loc <> + ", some values changed in the new package metadata: " <> + display pm + display (CRC32Mismatch loc fp Mismatch {..}) = + "CRC32 mismatch in ZIP file from " <> display loc <> + " on internal file " <> fromString fp <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (UnknownHackagePackage pir fuzzy) = + "Could not find " <> display pir <> " on Hackage" <> + displayFuzzy fuzzy + display (CannotCompleteRepoNonSHA1 repo) = + "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> + display repo + display (MutablePackageLocationFromUrl t) = + "Cannot refer to a mutable package location from a URL: " <> display t + display (MismatchedCabalFileForHackage pir Mismatch{..}) = + "When processing cabal file for Hackage package " <> display pir <> + ":\nMismatched package identifier." <> + "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> + "\nActual: " <> fromString (packageIdentifierString mismatchActual) + display (PackageNameParseFail t) = + "Invalid package name: " <> display t + display (PackageVersionParseFail t) = + "Invalid version: " <> display t + display (InvalidCabalFilePath fp) = + "File path contains a name which is not a valid package name: " <> + fromString (toFilePath fp) + display (DuplicatePackageNames source pairs') = + "Duplicate package names (" <> source <> "):\n" <> + foldMap + (\(name, locs) -> + fromString (packageNameString name) <> ":\n" <> + foldMap + (\loc -> "- " <> display loc <> "\n") + locs + ) + pairs' + display (MigrationFailure desc fp ex) = + "Encountered error while migrating " <> display desc <> " database:" <> + "\n " <> displayShow ex <> + "\nPlease report this on https://github.com/commercialhaskell/stack/issues" <> + "\nAs a workaround you may delete " <> display desc <> " database in " <> + fromString (toFilePath fp) <> " triggering its recreation." + display (ParseSnapNameException t) = "Invalid snapshot name: " <> display t + +data FuzzyResults + = FRNameNotFound ![PackageName] + | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) + | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) + +displayFuzzy :: FuzzyResults -> Utf8Builder +displayFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> "" + Just names' -> + "\nPerhaps you meant " <> + orSeparated (NE.map (fromString . packageNameString) names') <> + "?" +displayFuzzy (FRVersionNotFound pirs) = + "\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." +displayFuzzy (FRRevisionNotFound pirs) = + "\nThe specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." + +orSeparated :: NonEmpty Utf8Builder -> Utf8Builder +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder +commaSeparated = fold . NE.intersperse ", " + +cabalSpecLatestVersion :: Version +cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest + +#if !MIN_VERSION_Cabal(3,4,0) +cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] +cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] +cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] +cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] +cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] +cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] +cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] +cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] +cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] +cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] +cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] +cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] +cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] +cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] +cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] +cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] +#endif + +data BuildFile = BFCabal !SafeFilePath !TreeEntry + | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file + deriving (Show, Eq) + +data FileType = FTNormal | FTExecutable + deriving (Show, Eq, Enum, Bounded, Ord) +instance PersistField FileType where + toPersistValue FTNormal = PersistInt64 1 + toPersistValue FTExecutable = PersistInt64 2 + + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int64 of + 1 -> Right FTNormal + 2 -> Right FTExecutable + _ -> Left $ "Invalid FileType: " <> tshow i +instance PersistFieldSql FileType where + sqlType _ = SqlInt32 + +data TreeEntry = TreeEntry + { teBlob :: !BlobKey + , teType :: !FileType + } + deriving (Show, Eq, Ord) + +newtype SafeFilePath = SafeFilePath Text + deriving (Show, Eq, Ord, Display) + +instance PersistField SafeFilePath where + toPersistValue = toPersistValue . unSafeFilePath + fromPersistValue v = do + t <- fromPersistValue v + maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t +instance PersistFieldSql SafeFilePath where + sqlType _ = SqlString + +unSafeFilePath :: SafeFilePath -> Text +unSafeFilePath (SafeFilePath t) = t + +safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) +safeFilePathToPath dir (SafeFilePath path) = do + fpath <- parseRelFile (T.unpack path) + return $ dir fpath + +mkSafeFilePath :: Text -> Maybe SafeFilePath +mkSafeFilePath t = do + guard $ not $ "\\" `T.isInfixOf` t + guard $ not $ "//" `T.isInfixOf` t + guard $ not $ "\n" `T.isInfixOf` t + guard $ not $ "\0" `T.isInfixOf` t + + (c, _) <- T.uncons t + guard $ c /= '/' + + guard $ all (not . T.all (== '.')) $ T.split (== '/') t + + Just $ SafeFilePath t + +-- | SafeFilePath for `package.yaml` file. +hpackSafeFilePath :: SafeFilePath +hpackSafeFilePath = + let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) + in case fpath of + Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) + Just sfp -> sfp + +-- | The hash of the binary representation of a 'Tree'. +-- +-- @since 0.1.0.0 +newtype TreeKey = TreeKey BlobKey + deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) + +-- | Represents the contents of a tree, which is a mapping from +-- relative file paths to 'TreeEntry's. +-- +-- @since 0.1.0.0 +newtype Tree + = TreeMap (Map SafeFilePath TreeEntry) + -- In the future, consider allowing more lax parsing + -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys + -- TreeTarball !PackageTarball + deriving (Show, Eq, Ord) + +renderTree :: Tree -> ByteString +renderTree = BL.toStrict . toLazyByteString . go + where + go :: Tree -> Builder + go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m + + goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = + netstring (unSafeFilePath sfp) <> + byteString (SHA256.toRaw sha) <> + netword size' <> + (case ft of + FTNormal -> "N" + FTExecutable -> "X") + +netstring :: Text -> Builder +netstring t = + let bs = encodeUtf8 t + in netword (fromIntegral (B.length bs)) <> byteString bs + +netword :: Word -> Builder +netword w = wordDec w <> ":" + +parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) +parseTreeM (blobKey, blob) = + case parseTree blob of + Nothing -> throwM (InvalidTreeFromCasa blobKey blob) + Just tree -> pure (TreeKey blobKey, tree) + +parseTree :: ByteString -> Maybe Tree +parseTree bs1 = do + tree <- parseTree' bs1 + let bs2 = renderTree tree + guard $ bs1 == bs2 + Just tree + +parseTree' :: ByteString -> Maybe Tree +parseTree' bs0 = do + entriesBS <- B.stripPrefix "map:" bs0 + TreeMap <$> loop Map.empty entriesBS + where + loop !m bs1 + | B.null bs1 = pure m + | otherwise = do + (sfpBS, bs2) <- takeNetstring bs1 + sfp <- + case decodeUtf8' sfpBS of + Left _ -> Nothing + Right sfpT -> mkSafeFilePath sfpT + (sha, bs3) <- takeSha bs2 + (size', bs4) <- takeNetword bs3 + (typeW, bs5) <- B.uncons bs4 + ft <- + case typeW of + 78 -> Just FTNormal -- 'N' + 88 -> Just FTExecutable -- 'X' + _ -> Nothing + let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft + loop (Map.insert sfp entry m) bs5 + + takeNetstring bs1 = do + (size', bs2) <- takeNetword bs1 + guard $ B.length bs2 >= size' + Just $ B.splitAt size' bs2 + + takeSha bs = do + let (x, y) = B.splitAt 32 bs + x' <- either (const Nothing) Just (SHA256.fromRaw x) + Just (x', y) + + takeNetword = + go 0 + where + go !accum bs = do + (next, rest) <- B.uncons bs + if + | next == 58 -> pure (accum, rest) -- ':' + | next >= 48 && next <= 57 -> + go + (accum * 10 + fromIntegral (next - 48)) + rest + | otherwise -> Nothing + + {- +data PackageTarball = PackageTarball + { ptBlob :: !BlobKey + -- ^ Contains the tarball itself + , ptCabal :: !BlobKey + -- ^ Contains the cabal file contents + , ptSubdir :: !FilePath + -- ^ Subdir containing the files we want for this package. + -- + -- There must be precisely one file with a @.cabal@ file extension + -- located there. Thanks to Hackage revisions, its contents will be + -- overwritten by the value of @ptCabal@. + } + deriving Show + -} + +-- | This is almost a copy of Cabal's parser for package identifiers, +-- the main difference is in the fact that Stack requires version to be +-- present while Cabal uses "null version" as a default value +-- +-- @since 0.1.0.0 +parsePackageIdentifier :: String -> Maybe PackageIdentifier +parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) + +packageIdentifierParsec :: ParsecParser PackageIdentifier +packageIdentifierParsec = do + ident@(PackageIdentifier _ v) <- parsec + + -- version is a required component of a package identifier for Stack + guard (v /= nullVersion) + + pure ident + +-- | Parse a package name from a 'String'. +-- +-- @since 0.1.0.0 +parsePackageName :: String -> Maybe PackageName +parsePackageName = Distribution.Text.simpleParse + +-- | Parse a package name from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn + +-- | Parse a version from a 'String'. +-- +-- @since 0.1.0.0 +parseVersion :: String -> Maybe Version +parseVersion = Distribution.Text.simpleParse + +-- | Parse a package version from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of + Nothing -> throwM $ PackageVersionParseFail $ T.pack str + Just v -> pure v + +-- | Parse a version range from a 'String'. +-- +-- @since 0.1.0.0 +parseVersionRange :: String -> Maybe VersionRange +parseVersionRange = Distribution.Text.simpleParse + +-- | Parse a module name from a 'String'. +-- +-- @since 0.1.0.0 +parseModuleName :: String -> Maybe ModuleName +parseModuleName = Distribution.Text.simpleParse + +-- | Parse a flag name from a 'String'. +-- +-- @since 0.1.0.0 +parseFlagName :: String -> Maybe FlagName +parseFlagName = Distribution.Text.simpleParse + +-- | Render a package name as a 'String'. +-- +-- @since 0.1.0.0 +packageNameString :: PackageName -> String +packageNameString = unPackageName + +-- | Render a package identifier as a 'String'. +-- +-- @since 0.1.0.0 +packageIdentifierString :: PackageIdentifier -> String +packageIdentifierString = Distribution.Text.display + +-- | Render a version as a 'String'. +-- +-- @since 0.1.0.0 +versionString :: Version -> String +versionString = Distribution.Text.display + +-- | Render a flag name as a 'String'. +-- +-- @since 0.1.0.0 +flagNameString :: FlagName -> String +flagNameString = unFlagName + +-- | Render a module name as a 'String'. +-- +-- @since 0.1.0.0 +moduleNameString :: ModuleName -> String +moduleNameString = Distribution.Text.display + +data OptionalSubdirs + = OSSubdirs !(NonEmpty Text) + | OSPackageMetadata !Text !RawPackageMetadata + -- ^ subdirectory and package metadata + deriving (Show, Eq, Generic) +instance NFData OptionalSubdirs + +-- | Metadata provided by a config file for archives and repos. This +-- information can be used for optimized lookups of information like +-- package identifiers, or for validating that the user configuration +-- has the expected information. +-- +-- @since 0.1.0.0 +data RawPackageMetadata = RawPackageMetadata + { rpmName :: !(Maybe PackageName) + -- ^ Package name in the cabal file + -- + -- @since 0.1.0.0 + , rpmVersion :: !(Maybe Version) + -- ^ Package version in the cabal file + -- + -- @since 0.1.0.0 + , rpmTreeKey :: !(Maybe TreeKey) + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) +instance NFData RawPackageMetadata + +instance Display RawPackageMetadata where + display rpm = fold $ intersperse ", " $ catMaybes + [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm + , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm + , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm + ] + +-- | Exact metadata specifying concrete package +-- +-- @since 0.1.0.0 +data PackageMetadata = PackageMetadata + { pmIdent :: !PackageIdentifier + -- ^ Package identifier in the cabal file + -- + -- @since 0.1.0.0 + , pmTreeKey :: !TreeKey + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) +-- i PackageMetadata +instance NFData PackageMetadata + +instance Display PackageMetadata where + display pm = fold $ intersperse ", " $ + [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) + , "tree == " <> display (pmTreeKey pm) + ] + +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + +-- | Convert package metadata to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawPM :: PackageMetadata -> RawPackageMetadata +toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) + where + PackageIdentifier name version = pmIdent pm + +-- | File path relative to the configuration file it was parsed from +-- +-- @since 0.1.0.0 +newtype RelFilePath = RelFilePath Text + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) + +-- | Location that an archive is stored at +-- +-- @since 0.1.0.0 +data ArchiveLocation + = ALUrl !Text + -- ^ Archive stored at an HTTP(S) URL + -- + -- @since 0.1.0.0 + | ALFilePath !(ResolvedPath File) + -- ^ Archive stored at a local file path + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic, Typeable) +instance NFData ArchiveLocation + +instance Display ArchiveLocation where + display (ALUrl url) = display url + display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved + +parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) +parseArchiveLocationObject o = + ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|> + ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) <|> + ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) <|> + ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) + +parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) +parseArchiveLocationText t = + case validateUrl t of + Left e1 -> + case validateFilePath t of + Left e2 -> Left $ T.unlines + [ "Invalid archive location, neither a URL nor a file path" + , " URL error: " <> e1 + , " File path error: " <> e2 + ] + Right x -> Right x + Right x -> Right x + +validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) +validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> Left $ "Could not parse URL: " <> t + Right _ -> pure $ pure $ ALUrl t + +validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) +validateFilePath t = + if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' + else Left $ "Does not have an archive file extension: " <> t + +instance ToJSON RawPackageLocation where + toJSON (RPLImmutable rpli) = toJSON rpli + toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where + parseJSON v = + ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> + ((noJSONWarnings . mkMutable) <$> parseJSON v) + where + mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' + +instance ToJSON RawPackageLocationImmutable where + toJSON (RPLIHackage pir mtree) = object $ concat + [ ["hackage" .= pir] + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + ] + toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat + [ case loc of + ALUrl url -> ["url" .= url] + ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] + , maybe [] (\sha -> ["sha256" .= sha]) msha + , maybe [] (\size' -> ["size" .= size']) msize + , if T.null subdir then [] else ["subdir" .= subdir] + , rpmToPairs rpm + ] + toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat + [ [ urlKey .= url + , "commit" .= commit + ] + , if T.null subdir then [] else ["subdir" .= subdir] + , rpmToPairs rpm + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)] +rpmToPairs (RawPackageMetadata mname mversion mtree) = concat + [ maybe [] (\name -> ["name" .= CabalString name]) mname + , maybe [] (\version -> ["version" .= CabalString version]) mversion + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + ] + +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..:? "subdir" ..!= "" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) + + github value = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + pm <- parsePackageMetadata o + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let archiveLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ pure $ PLIArchive Archive {..} pm) value + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where + parseJSON v + = http v + <|> hackageText v + <|> hackageObject v + <|> repo v + <|> archiveObject v + <|> github v + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) + where + http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Left _ -> fail $ "Invalid archive location: " ++ T.unpack t + Right (Unresolved mkArchiveLocation) -> + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + let raHash = Nothing + raSize = Nothing + raSubdir = T.empty + pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty + + hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing + + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage + <$> o ..: "hackage" + <*> o ..:? "pantry-tree") + + optionalSubdirs :: Object -> WarningParser OptionalSubdirs + optionalSubdirs o = + -- if subdirs exists, it needs to be valid + case HM.lookup "subdirs" o of + Just v' -> do + tellJSONField "subdirs" + subdirs <- lift $ parseJSON v' + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> OSPackageMetadata + <$> o ..:? "subdir" ..!= T.empty + <*> (rawPackageMetadataHelper + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file") + + rawPackageMetadataHelper + :: Maybe PackageName + -> Maybe Version + -> Maybe TreeKey + -> Maybe BlobKey + -> RawPackageMetadata + rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = + RawPackageMetadata name version pantryTree + + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let raLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + +-- | Returns pairs of subdirectory and 'PackageMetadata'. +osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) +osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs +osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) + +rpmEmpty :: RawPackageMetadata +rpmEmpty = RawPackageMetadata Nothing Nothing Nothing + +-- | Newtype wrapper for easier JSON integration with Cabal types. +-- +-- @since 0.1.0.0 +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +-- I'd like to use coerce here, but can't due to roles. unsafeCoerce +-- could work, but let's avoid unsafe code. + +-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' +-- instance. +-- +-- @since 0.1.0.0 +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString + +-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a +-- 'FromJSON' instance. +-- +-- @since 0.1.0.0 +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString + +instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString +instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) +instance forall a. IsCabalString a => FromJSONKey (CabalString a) where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +class IsCabalString a where + cabalStringName :: proxy a -> String + cabalStringParser :: String -> Maybe a +instance IsCabalString PackageName where + cabalStringName _ = "package name" + cabalStringParser = parsePackageName +instance IsCabalString Version where + cabalStringName _ = "version" + cabalStringParser = parseVersion +instance IsCabalString VersionRange where + cabalStringName _ = "version range" + cabalStringParser = parseVersionRange +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" + cabalStringParser = parsePackageIdentifier +instance IsCabalString FlagName where + cabalStringName _ = "flag name" + cabalStringParser = parseFlagName + +-- | What to use for running hpack +-- +-- @since 0.1.0.0 +data HpackExecutable + = HpackBundled + -- ^ Compiled in library + | HpackCommand !FilePath + -- ^ Executable at the provided path + deriving (Show, Read, Eq, Ord) + + +-- | Which compiler a snapshot wants to use. The build tool may elect +-- to do some fuzzy matching of versions (e.g., allowing different +-- patch versions). +-- +-- @since 0.1.0.0 +data WantedCompiler + = WCGhc !Version + | WCGhcGit !Text !Text + | WCGhcjs + !Version + !Version + -- ^ GHCJS version followed by GHC version + deriving (Show, Eq, Ord, Generic) + +instance NFData WantedCompiler +instance Display WantedCompiler where + display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) + display (WCGhcjs vghcjs vghc) = + "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) + display (WCGhcGit commit flavour) = + "ghc-git-" <> display commit <> "-" <> display flavour +instance ToJSON WantedCompiler where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON WantedCompiler where + parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler +instance FromJSONKey WantedCompiler where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case parseWantedCompiler t of + Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e + Right x -> pure x + +-- | Parse a 'Text' into a 'WantedCompiler' value. +-- +-- @since 0.1.0.0 +parseWantedCompiler :: Text -> Either PantryException WantedCompiler +parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ + case T.stripPrefix "ghcjs-" t0 of + Just t1 -> parseGhcjs t1 + Nothing -> case T.stripPrefix "ghc-git-" t0 of + Just t1 -> parseGhcGit t1 + Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc + where + parseGhcjs t1 = do + let (ghcjsVT, t2) = T.break (== '_') t1 + ghcjsV <- parseVersion $ T.unpack ghcjsVT + ghcVT <- T.stripPrefix "_ghc-" t2 + ghcV <- parseVersion $ T.unpack ghcVT + pure $ WCGhcjs ghcjsV ghcV + parseGhcGit t1 = do + let (commit, flavour) = T.break (== '-') t1 + pure $ WCGhcGit commit (T.drop 1 flavour) + parseGhc = fmap WCGhc . parseVersion . T.unpack + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where + parseJSON v = text v <|> obj v + where + text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation + + obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> + ((pure . RSLCompiler) <$> o ..: "compiler") <|> + ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> + (parseRawSnapshotLocationPath <$> o ..: "filepath") + + blobKey o = do + msha <- o ..:? "sha256" + msize <- o ..:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + +instance Display SnapshotLocation where + display (SLCompiler compiler) = display compiler + display (SLUrl url blob) = display url <> " (" <> display blob <> ")" + display (SLFilePath resolved) = display (resolvedRelative resolved) + +-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ + (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> + (pure <$> RSLSynonym <$> parseSnapName t0) <|> + parseGitHub <|> + parseUrl + where + parseGitHub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ pure $ githubSnapshotLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) + +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath t = + Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + +githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation +githubSnapshotLocation user repo path = + let url = T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + in RSLUrl url Nothing + +defUser :: Text +defUser = "commercialhaskell" + +defRepo :: Text +defRepo = "stackage-snapshots" + +-- | Default location of snapshot synonyms +-- , i.e. commercialhaskell's GitHub repository. +-- +-- @since 0.5.0.0 +defaultSnapshotLocation + :: SnapName + -> RawSnapshotLocation +defaultSnapshotLocation (LTS x y) = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "lts/" <> display x <> "/" <> display y <> ".yaml" +defaultSnapshotLocation (Nightly date) = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" + where + (year, month, day) = toGregorian date + +-- | A snapshot synonym. +-- It is expanded according to the field 'snapshotLocation' +-- of a 'PantryConfig'. +-- +-- @ since 0.5.0.0 +data SnapName + -- | LTS Haskell snapshot, + -- displayed as @"lts-maj.min"@. + -- + -- @since 0.5.0.0 + = LTS + !Int -- ^ Major version + !Int -- ^ Minor version + -- | Stackage Nightly snapshot, + -- displayed as @"nighly-YYYY-MM-DD"@. + -- + -- @since 0.5.0.0 + | Nightly !Day + deriving (Eq, Ord, Generic) + +instance NFData SnapName + +instance Display SnapName where + display (LTS x y) = "lts-" <> display x <> "." <> display y + display (Nightly date) = "nightly-" <> displayShow date + +instance Show SnapName where + show = T.unpack . utf8BuilderToText . display + +instance ToJSON SnapName where + toJSON syn = String $ utf8BuilderToText $ display syn + +-- | Parse the short representation of a 'SnapName'. +-- +-- @since 0.5.0.0 +parseSnapName :: MonadThrow m => Text -> m SnapName +parseSnapName t0 = + case lts <|> nightly of + Nothing -> throwM $ ParseSnapNameException t0 + Just sn -> return sn + where + lts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ LTS x y + nightly = do + t1 <- T.stripPrefix "nightly-" t0 + Nightly <$> readMaybe (T.unpack t1) + +-- | Where to load a snapshot from in raw form +-- (RSUrl could have a missing BlobKey) +-- +-- @since 0.1.0.0 +data RawSnapshotLocation + = RSLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | RSLUrl !Text !(Maybe BlobKey) + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | RSLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + | RSLSynonym !SnapName + -- ^ Snapshot synonym (LTS/Nightly). + -- + -- @since 0.5.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData RawSnapshotLocation + +instance Display RawSnapshotLocation where + display (RSLCompiler compiler) = display compiler + display (RSLUrl url Nothing) = display url + display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" + display (RSLFilePath resolved) = display (resolvedRelative resolved) + display (RSLSynonym syn) = display syn + + +instance ToJSON RawSnapshotLocation where + toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] + toJSON (RSLUrl url mblob) = object + $ "url" .= url + : maybe [] blobKeyPairs mblob + toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] + toJSON (RSLSynonym syn) = toJSON syn + +-- | Where to load a snapshot from. +-- +-- @since 0.1.0.0 +data SnapshotLocation + = SLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | SLUrl !Text !BlobKey + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | SLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic) +instance NFData SnapshotLocation + +instance ToJSON SnapshotLocation where + toJSON sl = toJSON (toRawSL sl) + +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ SLFilePath fp + url = withObjectWarnings "SLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha256" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "SLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ SLCompiler c + +-- | Convert snapshot location to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSL :: SnapshotLocation -> RawSnapshotLocation +toRawSL (SLCompiler c) = RSLCompiler c +toRawSL (SLUrl url blob) = RSLUrl url (Just blob) +toRawSL (SLFilePath fp) = RSLFilePath fp + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshot = RawSnapshot + { rsCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , rsPackages :: !(Map PackageName RawSnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , rsDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data Snapshot = Snapshot + { snapshotCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , snapshotPackages :: !(Map PackageName SnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , snapshotDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshotPackage = RawSnapshotPackage + { rspLocation :: !RawPackageLocationImmutable + -- ^ Where to get the package from + , rspFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , rspHidden :: !Bool + -- ^ Same as 'slHidden' + , rspGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data SnapshotPackage = SnapshotPackage + { spLocation :: !PackageLocationImmutable + -- ^ Where to get the package from + , spFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , spHidden :: !Bool + -- ^ Same as 'slHidden' + , spGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + deriving Show + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data RawSnapshotLayer = RawSnapshotLayer + { rslParent :: !RawSnapshotLocation + -- ^ The sl to extend from. This is either a specific + -- compiler, or a @SnapshotLocation@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + -- + -- @since 0.1.0.0 + , rslCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be + -- 'Nothing' if using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , rslLocations :: ![RawPackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , rslDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + -- + -- @since 0.1.0.0 + , rslFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , rslHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , rslGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , rslPublishTime :: !(Maybe UTCTime) + -- ^ See 'slPublishTime' + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance NFData RawSnapshotLayer + +instance ToJSON RawSnapshotLayer where + toJSON rsnap = object $ concat + [ ["resolver" .= rslParent rsnap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) + , ["packages" .= rslLocations rsnap] + , if Set.null (rslDropPackages rsnap) + then [] + else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] + , if Map.null (rslFlags rsnap) + then [] + else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] + , if Map.null (rslHidden rsnap) + then [] + else ["hidden" .= toCabalStringMap (rslHidden rsnap)] + , if Map.null (rslGhcOptions rsnap) + then [] + else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] + , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) + ] + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where + parseJSON = withObjectWarnings "Snapshot" $ \o -> do + _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format + mcompiler <- o ..:? "compiler" + mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) + (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure (sl, mcompiler) + + unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) + rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + rslPublishTime <- o ..:? "publish-time" + pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) + <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) + <*> unresolvedSnapshotParent + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data SnapshotLayer = SnapshotLayer + { slParent :: !SnapshotLocation + -- ^ The sl to extend from. This is either a specific + -- compiler, or a @SnapshotLocation@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + -- + -- @since 0.1.0.0 + , slCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be + -- 'Nothing' if using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , slLocations :: ![PackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , slDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + -- + -- @since 0.1.0.0 + , slFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , slHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , slGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , slPublishTime :: !(Maybe UTCTime) + -- ^ Publication timestamp for this snapshot. This field is optional, and + -- is for informational purposes only. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance ToJSON SnapshotLayer where + toJSON snap = object $ concat + [ ["resolver" .= slParent snap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) + , ["packages" .= slLocations snap] + , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] + , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] + , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] + , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] + , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) + ] + +-- | Convert snapshot layer into its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer +toRawSnapshotLayer sl = RawSnapshotLayer + { rslParent = toRawSL (slParent sl) + , rslCompiler = slCompiler sl + , rslLocations = map toRawPLI (slLocations sl) + , rslDropPackages = slDropPackages sl + , rslFlags = slFlags sl + , rslHidden = slHidden sl + , rslGhcOptions = slGhcOptions sl + , rslPublishTime = slPublishTime sl + } + +-- | An arbitrary hash for a snapshot, used for finding module names +-- in a snapshot. Mostly intended for Stack's usage. +-- +-- @since 0.1.0.0 +newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} + deriving (Show) + +-- | Get the path to the global hints cache file +getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) +getGlobalHintsFile = do + root <- view $ pantryConfigL.to pcRootDir + globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" + pure $ root globalHintsRelFile + +-- | Creates BlobKey for an input ByteString +-- +-- @since 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + +-- | Warn if the package uses 'PCHpack'. +-- +-- @since 0.4.0.0 +warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () +warnMissingCabalFile loc = + logWarn $ + "DEPRECATED: The package at " <> display loc <> + " does not include a cabal file.\n" <> + "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> + "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> + "Support for this workflow will be removed in the future.\n" diff --git a/src/unix/System/IsWindows.hs b/src/unix/System/IsWindows.hs --- a/src/unix/System/IsWindows.hs +++ b/src/unix/System/IsWindows.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module System.IsWindows - ( osIsWindows - ) where - -import RIO (Bool (..)) - --- | False if not using Windows OS. -osIsWindows :: Bool -osIsWindows = False +{-# LANGUAGE NoImplicitPrelude #-} +module System.IsWindows + ( osIsWindows + ) where + +import RIO (Bool (..)) + +-- | False if not using Windows OS. +osIsWindows :: Bool +osIsWindows = False diff --git a/src/windows/System/IsWindows.hs b/src/windows/System/IsWindows.hs --- a/src/windows/System/IsWindows.hs +++ b/src/windows/System/IsWindows.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module System.IsWindows - ( osIsWindows - ) where - -import RIO (Bool (..)) - --- | True if using Windows OS. -osIsWindows :: Bool -osIsWindows = True +{-# LANGUAGE NoImplicitPrelude #-} +module System.IsWindows + ( osIsWindows + ) where + +import RIO (Bool (..)) + +-- | True if using Windows OS. +osIsWindows :: Bool +osIsWindows = True diff --git a/test/Pantry/ArchiveSpec.hs b/test/Pantry/ArchiveSpec.hs --- a/test/Pantry/ArchiveSpec.hs +++ b/test/Pantry/ArchiveSpec.hs @@ -1,103 +1,103 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Pantry.ArchiveSpec (spec) where - -import Test.Hspec -import Data.Maybe (fromJust) -import RIO -import RIO.Text as T -import Pantry -import Path.IO (resolveFile') - -data TestLocation - = TLFilePath String - | TLUrl Text - -data TestArchive = TestArchive - { testLocation :: !TestLocation - , testSubdir :: !Text - } - -getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier -getRawPackageLocationIdent' TestArchive{..} = do - testLocation' <- case testLocation of - TLFilePath relPath -> do - absPath <- resolveFile' relPath - return $ ALFilePath $ ResolvedPath - { resolvedRelative = RelFilePath $ fromString relPath - , resolvedAbsolute = absPath - } - TLUrl url -> return $ ALUrl url - let archive = RawArchive - { raLocation = testLocation' - , raHash = Nothing - , raSize = Nothing - , raSubdir = testSubdir - } - runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata - where - metadata = RawPackageMetadata - { rpmName = Nothing - , rpmVersion = Nothing - , rpmTreeKey = Nothing - } - -parsePackageIdentifier' :: String -> PackageIdentifier -parsePackageIdentifier' = fromJust . parsePackageIdentifier - -urlToStackCommit :: Text -> TestLocation -urlToStackCommit commit = TLUrl $ T.concat - [ "https://github.com/commercialhaskell/stack/archive/" - , commit - , ".tar.gz" - ] - -treeWithoutCabalFile :: Selector PantryException -treeWithoutCabalFile (TreeWithoutCabalFile _) = True -treeWithoutCabalFile _ = False - -spec :: Spec -spec = do - it "finds cabal file from tarball" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" - , testSubdir = "" - } - ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" - it "finds cabal file from tarball with subdir '.'" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" - , testSubdir = "." - } - ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" - it "finds cabal file from tarball with a package.yaml" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" - , testSubdir = "" - } - ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" - it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" - , testSubdir = "." - } - ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" - it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" - , testSubdir = "subs/pantry/" - } - ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" - it "matches whole directory name" $ - getRawPackageLocationIdent' TestArchive - { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" - , testSubdir = "subs/pant" - } - `shouldThrow` treeWithoutCabalFile - it "follows symlinks to directories" $ do - ident <- getRawPackageLocationIdent' TestArchive - { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" - , testSubdir = "symlink" - } - ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Pantry.ArchiveSpec (spec) where + +import Test.Hspec +import Data.Maybe (fromJust) +import RIO +import RIO.Text as T +import Pantry +import Path.IO (resolveFile') + +data TestLocation + = TLFilePath String + | TLUrl Text + +data TestArchive = TestArchive + { testLocation :: !TestLocation + , testSubdir :: !Text + } + +getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier +getRawPackageLocationIdent' TestArchive{..} = do + testLocation' <- case testLocation of + TLFilePath relPath -> do + absPath <- resolveFile' relPath + return $ ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ fromString relPath + , resolvedAbsolute = absPath + } + TLUrl url -> return $ ALUrl url + let archive = RawArchive + { raLocation = testLocation' + , raHash = Nothing + , raSize = Nothing + , raSubdir = testSubdir + } + runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata + where + metadata = RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + } + +parsePackageIdentifier' :: String -> PackageIdentifier +parsePackageIdentifier' = fromJust . parsePackageIdentifier + +urlToStackCommit :: Text -> TestLocation +urlToStackCommit commit = TLUrl $ T.concat + [ "https://github.com/commercialhaskell/stack/archive/" + , commit + , ".tar.gz" + ] + +treeWithoutCabalFile :: Selector PantryException +treeWithoutCabalFile (TreeWithoutCabalFile _) = True +treeWithoutCabalFile _ = False + +spec :: Spec +spec = do + it "finds cabal file from tarball" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "" + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with subdir '.'" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "." + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with a package.yaml" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" + , testSubdir = "" + } + ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" + it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" + , testSubdir = "." + } + ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" + it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pantry/" + } + ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" + it "matches whole directory name" $ + getRawPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pant" + } + `shouldThrow` treeWithoutCabalFile + it "follows symlinks to directories" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" + , testSubdir = "symlink" + } + ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" diff --git a/test/Pantry/BuildPlanSpec.hs b/test/Pantry/BuildPlanSpec.hs --- a/test/Pantry/BuildPlanSpec.hs +++ b/test/Pantry/BuildPlanSpec.hs @@ -1,119 +1,119 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Pantry.BuildPlanSpec where - -import Pantry.Internal.AesonExtended (WithJSONWarnings(..)) -import RIO -import qualified Data.ByteString.Char8 as S8 -import Data.Yaml (decodeThrow) -import Pantry -import Test.Hspec -import Control.Monad.Catch (MonadThrow) -import Data.List.NonEmpty (NonEmpty) - -spec :: Spec -spec = - describe "PackageLocation" $ do - describe "Archive" $ do - describe "github" $ do - let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) - decode' = decodeThrow - - decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) - decode'' bs = do - WithJSONWarnings unresolved warnings <- decode' bs - unless (null warnings) $ error $ show warnings - resolvePaths Nothing unresolved - - it "'github' and 'commit' keys" $ do - let contents :: ByteString - contents = - S8.pack - (unlines - [ "github: oink/town" - , "commit: abc123" - ]) - let expected :: RawPackageLocationImmutable - expected = - RPLIArchive - RawArchive - { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" - , raHash = Nothing - , raSize = Nothing - , raSubdir = "" - } - RawPackageMetadata - { rpmName = Nothing - , rpmVersion = Nothing - , rpmTreeKey = Nothing - } - actual <- decode'' contents - actual `shouldBe` pure expected - - it "'github', 'commit', and 'subdirs' keys" $ do - let contents :: ByteString - contents = - S8.pack - (unlines - [ "github: oink/town" - , "commit: abc123" - , "subdirs:" - , " - foo" - ]) - let expected :: RawPackageLocationImmutable - expected = - RPLIArchive - RawArchive - { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" - , raHash = Nothing - , raSize = Nothing - , raSubdir = "foo" - } - RawPackageMetadata - { rpmName = Nothing - , rpmVersion = Nothing - , rpmTreeKey = Nothing - } - actual <- decode'' contents - actual `shouldBe` pure expected - - it "does not parse GitHub repo with no slash" $ do - let contents :: ByteString - contents = - S8.pack - (unlines - [ "github: oink" - , "commit: abc123" - ]) - void (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" - ]) - void (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" - ]) - void (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" - ]) - void (decode' contents) `shouldBe` Nothing +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Pantry.BuildPlanSpec where + +import Pantry.Internal.AesonExtended (WithJSONWarnings(..)) +import RIO +import qualified Data.ByteString.Char8 as S8 +import Data.Yaml (decodeThrow) +import Pantry +import Test.Hspec +import Control.Monad.Catch (MonadThrow) +import Data.List.NonEmpty (NonEmpty) + +spec :: Spec +spec = + describe "PackageLocation" $ do + describe "Archive" $ do + describe "github" $ do + let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + decode' = decodeThrow + + decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) + decode'' bs = do + WithJSONWarnings unresolved warnings <- decode' bs + unless (null warnings) $ error $ show warnings + resolvePaths Nothing unresolved + + it "'github' and 'commit' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + ]) + let expected :: RawPackageLocationImmutable + expected = + RPLIArchive + RawArchive + { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , raHash = Nothing + , raSize = Nothing + , raSubdir = "" + } + RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + } + actual <- decode'' contents + actual `shouldBe` pure expected + + it "'github', 'commit', and 'subdirs' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + , "subdirs:" + , " - foo" + ]) + let expected :: RawPackageLocationImmutable + expected = + RPLIArchive + RawArchive + { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , raHash = Nothing + , raSize = Nothing + , raSubdir = "foo" + } + RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + } + actual <- decode'' contents + actual `shouldBe` pure expected + + it "does not parse GitHub repo with no slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink" + , "commit: abc123" + ]) + void (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" + ]) + void (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" + ]) + void (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" + ]) + void (decode' contents) `shouldBe` Nothing diff --git a/test/Pantry/CabalSpec.hs b/test/Pantry/CabalSpec.hs --- a/test/Pantry/CabalSpec.hs +++ b/test/Pantry/CabalSpec.hs @@ -1,100 +1,100 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Pantry.CabalSpec (spec) where - -import Test.Hspec -import Pantry -import qualified Pantry.SHA256 as SHA256 -import RIO -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) - -spec :: Spec -spec = describe "wrong cabal file" $ do - let test :: HasCallStack => String -> RIO PantryApp () -> Spec - test name action = it name (runPantryApp action :: IO ()) - shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y - test "Hackage" $ do - sha <- either throwIO pure - $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" - let rpli = - RPLIHackage - (PackageIdentifierRevision - name - version3 - (CFIHash sha (Just size))) - Nothing - go = loadCabalFileRawImmutable rpli - name = mkPackageName "acme-missiles" - version2 = mkVersion [0, 2] - version3 = mkVersion [0, 3] - size = FileSize 597 - go `shouldThrow'` \e -> - case e of - MismatchedPackageMetadata rpli' rpm _tree ident -> - rpli == rpli' && - rpm == RawPackageMetadata - { rpmName = Just name - , rpmVersion = Just version3 - , rpmTreeKey = Nothing - } && - ident == PackageIdentifier name version2 - _ -> False - - test "tarball with wrong ident" $ do - archiveHash' <- either throwIO pure - $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" - let rpli = RPLIArchive archive rpm - archive = - RawArchive - { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" - , raHash = Just archiveHash' - , raSize = Just $ FileSize 309199 - , raSubdir = "yesod-auth" - } - rpm = - RawPackageMetadata - { rpmName = Just acmeMissiles - , rpmVersion = Just version2 - , rpmTreeKey = Nothing - } - go = loadCabalFileRawImmutable rpli - acmeMissiles = mkPackageName "acme-missiles" - version2 = mkVersion [0, 2] - go `shouldThrow'` \e -> - case e of - MismatchedPackageMetadata rpli' rpm' _treeKey ident -> - rpli == rpli' && - rpm == rpm' && - ident == PackageIdentifier - (mkPackageName "yesod-auth") - (mkVersion [1, 6, 4, 1]) - _ -> False - - test "tarball with wrong cabal file" $ do - let rpli = RPLIArchive archive rpm - archive = - RawArchive - { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" - , raHash = either impureThrow Just - $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" - , raSize = Just $ FileSize 309199 - , raSubdir = "yesod-auth" - } - rpm = - RawPackageMetadata - { rpmName = Just yesodAuth - , rpmVersion = Just badVersion - , rpmTreeKey = Nothing - } - go = loadCabalFileRawImmutable rpli - yesodAuth = mkPackageName "yesod-auth" - version = mkVersion [1, 6, 4, 1] - badVersion = mkVersion [1, 6, 4, 0] - go `shouldThrow'` \e -> - case e of - MismatchedPackageMetadata rpli' rpm' _treeKey ident -> - rpli == rpli' && - rpm == rpm' && - ident == PackageIdentifier yesodAuth version - _ -> False +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.CabalSpec (spec) where + +import Test.Hspec +import Pantry +import qualified Pantry.SHA256 as SHA256 +import RIO +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) + +spec :: Spec +spec = describe "wrong cabal file" $ do + let test :: HasCallStack => String -> RIO PantryApp () -> Spec + test name action = it name (runPantryApp action :: IO ()) + shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y + test "Hackage" $ do + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + let rpli = + RPLIHackage + (PackageIdentifierRevision + name + version3 + (CFIHash sha (Just size))) + Nothing + go = loadCabalFileRawImmutable rpli + name = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + version3 = mkVersion [0, 3] + size = FileSize 597 + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm _tree ident -> + rpli == rpli' && + rpm == RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version3 + , rpmTreeKey = Nothing + } && + ident == PackageIdentifier name version2 + _ -> False + + test "tarball with wrong ident" $ do + archiveHash' <- either throwIO pure + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + let rpli = RPLIArchive archive rpm + archive = + RawArchive + { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , raHash = Just archiveHash' + , raSize = Just $ FileSize 309199 + , raSubdir = "yesod-auth" + } + rpm = + RawPackageMetadata + { rpmName = Just acmeMissiles + , rpmVersion = Just version2 + , rpmTreeKey = Nothing + } + go = loadCabalFileRawImmutable rpli + acmeMissiles = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm' _treeKey ident -> + rpli == rpli' && + rpm == rpm' && + ident == PackageIdentifier + (mkPackageName "yesod-auth") + (mkVersion [1, 6, 4, 1]) + _ -> False + + test "tarball with wrong cabal file" $ do + let rpli = RPLIArchive archive rpm + archive = + RawArchive + { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , raHash = either impureThrow Just + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + , raSize = Just $ FileSize 309199 + , raSubdir = "yesod-auth" + } + rpm = + RawPackageMetadata + { rpmName = Just yesodAuth + , rpmVersion = Just badVersion + , rpmTreeKey = Nothing + } + go = loadCabalFileRawImmutable rpli + yesodAuth = mkPackageName "yesod-auth" + version = mkVersion [1, 6, 4, 1] + badVersion = mkVersion [1, 6, 4, 0] + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm' _treeKey ident -> + rpli == rpli' && + rpm == rpm' && + ident == PackageIdentifier yesodAuth version + _ -> False diff --git a/test/Pantry/CasaSpec.hs b/test/Pantry/CasaSpec.hs --- a/test/Pantry/CasaSpec.hs +++ b/test/Pantry/CasaSpec.hs @@ -1,95 +1,95 @@ -{-# LANGUAGE OverloadedStrings #-} -module Pantry.CasaSpec (spec) where - -import Distribution.Types.Version (mkVersion) -import Pantry -import Pantry.SHA256 -import Test.Hspec - -spec :: Spec -spec = do - loadHackagePackageSpec - completeSpec - -completeSpec :: Spec -completeSpec = - it - "completePackageLocation: unliftio_0_2_12" - (shouldReturn - (runPantryAppClean - (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) - ( PLIHackage - (PackageIdentifier - { pkgName = "unliftio" - , pkgVersion = mkVersion [0, 2, 12] - }) - (argsCabalKey unliftio_0_2_12) - (argsTreeKey unliftio_0_2_12))) - -loadHackagePackageSpec :: Spec -loadHackagePackageSpec = do - it - "loadPackageRaw Exact hackage lookup" - (shouldReturn - (fmap - packageTreeKey - (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) - (argsTreeKey unliftio_0_2_12)) - it - "loadHackagePackageRaw Exact hackage lookup" - (shouldReturn - (fmap - packageTreeKey - (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) - (argsTreeKey unliftio_0_2_12)) - it - "loadHackagePackageRawViaCasa Exact hackage lookup" - (shouldReturn - (fmap - (fmap packageTreeKey) - (runPantryAppClean - (tryLoadPackageRawViaCasa - (argsRlpi unliftio_0_2_12) - (argsTreeKey unliftio_0_2_12)))) - (Just (argsTreeKey unliftio_0_2_12))) - -data Args = - Args - { argsRlpi :: !RawPackageLocationImmutable - , argsTreeKey :: !TreeKey - , argsRevision :: !PackageIdentifierRevision - , argsCabalKey :: !BlobKey - } - -unliftio_0_2_12 :: Args -unliftio_0_2_12 = - let cabalHash = (either - (error . show) - id - (fromHexText - "b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483")) - cabalLen = FileSize 3325 - cabalFileHash = - CFIHash - cabalHash - (Just cabalLen) - casaTreeKey = - TreeKey - (BlobKey - (either - (error . show) - id - (fromHexText - "4971b43f3d473eff868eb1a0c359729b49f1779e78c462ba45ef0d1eda677699")) - (FileSize 2229)) - pir = - PackageIdentifierRevision - "unliftio" - (mkVersion [0, 2, 12]) - cabalFileHash - in Args - { argsRevision = pir - , argsRlpi = RPLIHackage pir (Just casaTreeKey) - , argsTreeKey = casaTreeKey - , argsCabalKey = BlobKey cabalHash cabalLen - } +{-# LANGUAGE OverloadedStrings #-} +module Pantry.CasaSpec (spec) where + +import Distribution.Types.Version (mkVersion) +import Pantry +import Pantry.SHA256 +import Test.Hspec + +spec :: Spec +spec = do + loadHackagePackageSpec + completeSpec + +completeSpec :: Spec +completeSpec = + it + "completePackageLocation: unliftio_0_2_12" + (shouldReturn + (runPantryAppClean + (cplComplete <$> completePackageLocation (argsRlpi unliftio_0_2_12))) + ( PLIHackage + (PackageIdentifier + { pkgName = "unliftio" + , pkgVersion = mkVersion [0, 2, 12] + }) + (argsCabalKey unliftio_0_2_12) + (argsTreeKey unliftio_0_2_12))) + +loadHackagePackageSpec :: Spec +loadHackagePackageSpec = do + it + "loadPackageRaw Exact hackage lookup" + (shouldReturn + (fmap + packageTreeKey + (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) + (argsTreeKey unliftio_0_2_12)) + it + "loadHackagePackageRaw Exact hackage lookup" + (shouldReturn + (fmap + packageTreeKey + (runPantryAppClean (loadPackageRaw (argsRlpi unliftio_0_2_12)))) + (argsTreeKey unliftio_0_2_12)) + it + "loadHackagePackageRawViaCasa Exact hackage lookup" + (shouldReturn + (fmap + (fmap packageTreeKey) + (runPantryAppClean + (tryLoadPackageRawViaCasa + (argsRlpi unliftio_0_2_12) + (argsTreeKey unliftio_0_2_12)))) + (Just (argsTreeKey unliftio_0_2_12))) + +data Args = + Args + { argsRlpi :: !RawPackageLocationImmutable + , argsTreeKey :: !TreeKey + , argsRevision :: !PackageIdentifierRevision + , argsCabalKey :: !BlobKey + } + +unliftio_0_2_12 :: Args +unliftio_0_2_12 = + let cabalHash = (either + (error . show) + id + (fromHexText + "b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483")) + cabalLen = FileSize 3325 + cabalFileHash = + CFIHash + cabalHash + (Just cabalLen) + casaTreeKey = + TreeKey + (BlobKey + (either + (error . show) + id + (fromHexText + "4971b43f3d473eff868eb1a0c359729b49f1779e78c462ba45ef0d1eda677699")) + (FileSize 2229)) + pir = + PackageIdentifierRevision + "unliftio" + (mkVersion [0, 2, 12]) + cabalFileHash + in Args + { argsRevision = pir + , argsRlpi = RPLIHackage pir (Just casaTreeKey) + , argsTreeKey = casaTreeKey + , argsCabalKey = BlobKey cabalHash cabalLen + } diff --git a/test/Pantry/FileSpec.hs b/test/Pantry/FileSpec.hs --- a/test/Pantry/FileSpec.hs +++ b/test/Pantry/FileSpec.hs @@ -1,18 +1,18 @@ -module Pantry.FileSpec (spec) where - -import Test.Hspec -import Pantry -import Path -import Path.IO -import Control.Monad (void) - -spec :: Spec -spec = describe "loadCabalFilePath" $ do - it "sanity" $ do - abs' <- resolveDir' "." - (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath abs' - suffix <- parseRelFile "pantry.cabal" - cabalfp `shouldBe` abs' suffix - name' <- parsePackageNameThrowing "pantry" - name `shouldBe` name' - void $ f NoPrintWarnings +module Pantry.FileSpec (spec) where + +import Test.Hspec +import Pantry +import Path +import Path.IO +import Control.Monad (void) + +spec :: Spec +spec = describe "loadCabalFilePath" $ do + it "sanity" $ do + abs' <- resolveDir' "." + (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath abs' + suffix <- parseRelFile "pantry.cabal" + cabalfp `shouldBe` abs' suffix + name' <- parsePackageNameThrowing "pantry" + name `shouldBe` name' + void $ f NoPrintWarnings diff --git a/test/Pantry/GlobalHintsSpec.hs b/test/Pantry/GlobalHintsSpec.hs --- a/test/Pantry/GlobalHintsSpec.hs +++ b/test/Pantry/GlobalHintsSpec.hs @@ -1,41 +1,41 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Pantry.GlobalHintsSpec (spec) where - -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Version (mkVersion) -import RIO -import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) -import Pantry.Internal -import Test.Hspec -import qualified RIO.Map as Map -import Path (toFilePath) - -spec :: Spec -spec = do - let it' name inner = it name $ example $ runPantryAppClean $ do - file <- getGlobalHintsFile - writeFileBinary (toFilePath file) "this should be ignored" - inner - it' "unknown compiler" $ do - mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) - liftIO $ mmap `shouldBe` Nothing - it' "known compiler" $ do - mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) - case mmap of - Nothing -> error "not found" - Just m -> liftIO $ do - Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) - Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) - Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) - Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing - it' "older known compiler" $ do - mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) - case mmap of - Nothing -> error "not found" - Just m -> liftIO $ do - Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) - Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) - Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) - Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.GlobalHintsSpec (spec) where + +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) +import RIO +import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) +import Pantry.Internal +import Test.Hspec +import qualified RIO.Map as Map +import Path (toFilePath) + +spec :: Spec +spec = do + let it' name inner = it name $ example $ runPantryAppClean $ do + file <- getGlobalHintsFile + writeFileBinary (toFilePath file) "this should be ignored" + inner + it' "unknown compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) + liftIO $ mmap `shouldBe` Nothing + it' "known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) + Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing + it' "older known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) + Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing diff --git a/test/Pantry/HackageSpec.hs b/test/Pantry/HackageSpec.hs --- a/test/Pantry/HackageSpec.hs +++ b/test/Pantry/HackageSpec.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Pantry.HackageSpec (spec) where - -import Test.Hspec -import Pantry -import RIO -import Distribution.Types.Version (mkVersion) - -spec :: Spec -spec = do - it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing - it "fuzzy lookup kicks in" $ do - let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest - runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) - `shouldThrow` \e -> - case e of - UnknownHackagePackage pir' _ -> pir == pir' - _ -> False - -- Flaky test, can be broken by new packages on Hackage. - it "finds acme-missiles" $ do - x <- runPantryApp (getHackageTypoCorrections "acme-missile") - x `shouldSatisfy` ("acme-missiles" `elem`) +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.HackageSpec (spec) where + +import Test.Hspec +import Pantry +import RIO +import Distribution.Types.Version (mkVersion) + +spec :: Spec +spec = do + it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing + it "fuzzy lookup kicks in" $ do + let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest + runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) + `shouldThrow` \e -> + case e of + UnknownHackagePackage pir' _ -> pir == pir' + _ -> False + -- Flaky test, can be broken by new packages on Hackage. + it "finds acme-missiles" $ do + x <- runPantryApp (getHackageTypoCorrections "acme-missile") + x `shouldSatisfy` ("acme-missiles" `elem`) diff --git a/test/Pantry/Internal/StaticBytesSpec.hs b/test/Pantry/Internal/StaticBytesSpec.hs --- a/test/Pantry/Internal/StaticBytesSpec.hs +++ b/test/Pantry/Internal/StaticBytesSpec.hs @@ -1,76 +1,76 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Pantry.Internal.StaticBytesSpec (spec) where - -import RIO -import Pantry.Internal.StaticBytes -import Control.Monad (replicateM) -import qualified Data.ByteString as B -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -spec :: Spec -spec = do - describe "ByteString" $ tests B.pack - describe "Storable Vector" $ tests VS.fromList - describe "Unboxed Vector" $ tests VU.fromList - describe "Primitive Vector" $ tests VP.fromList - -tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec -tests pack = do - it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> - toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) - it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let octets = [w1,w2,w3,w4,w5,w6,w7,w8] - (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) - actual = either impureThrow id $ toStaticExact (pack octets) - actual `shouldBe` expected - - it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let octets = [w1,w2,w3,w4,w5,w6,w7,w8] - v1 = pack octets - (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 - v2 = fromStatic b8 - v2 `shouldBe` v1 - - it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do - let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] - case toStaticExact bs of - Left e -> throwIO e - Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs - toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) - it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do - let ws = [w1,w2,w3,w4] - bs1 = pack $ ws ++ replicate 4 0 - bs2 = pack ws - Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 - - prop "handles bytes16" $ \octets -> do - let bs = pack $ take 16 octets - (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs - fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) - - it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do - let bs = pack ws - (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs - fromStatic b16 `shouldBe` pack ws - - prop "handles bytes32" $ \octets -> do - let bs = pack $ take 32 octets - (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs - fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) - - prop "fuzz with encodeUtf8" $ \chars -> do - let t = T.pack $ filter (/= '\0') chars - bs = TE.encodeUtf8 t - bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 - b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 - - fromStatic b128 `shouldBe` bs128 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.Internal.StaticBytesSpec (spec) where + +import RIO +import Pantry.Internal.StaticBytes +import Control.Monad (replicateM) +import qualified Data.ByteString as B +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +spec :: Spec +spec = do + describe "ByteString" $ tests B.pack + describe "Storable Vector" $ tests VS.fromList + describe "Unboxed Vector" $ tests VU.fromList + describe "Primitive Vector" $ tests VP.fromList + +tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec +tests pack = do + it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> + toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) + it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] + (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) + actual = either impureThrow id $ toStaticExact (pack octets) + actual `shouldBe` expected + + it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] + v1 = pack octets + (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 + v2 = fromStatic b8 + v2 `shouldBe` v1 + + it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] + case toStaticExact bs of + Left e -> throwIO e + Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs + toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) + it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do + let ws = [w1,w2,w3,w4] + bs1 = pack $ ws ++ replicate 4 0 + bs2 = pack ws + Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 + + prop "handles bytes16" $ \octets -> do + let bs = pack $ take 16 octets + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) + + it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do + let bs = pack ws + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack ws + + prop "handles bytes32" $ \octets -> do + let bs = pack $ take 32 octets + (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs + fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) + + prop "fuzz with encodeUtf8" $ \chars -> do + let t = T.pack $ filter (/= '\0') chars + bs = TE.encodeUtf8 t + bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 + b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 + + fromStatic b128 `shouldBe` bs128 diff --git a/test/Pantry/InternalSpec.hs b/test/Pantry/InternalSpec.hs --- a/test/Pantry/InternalSpec.hs +++ b/test/Pantry/InternalSpec.hs @@ -1,74 +1,74 @@ -module Pantry.InternalSpec (spec) where - -import Test.Hspec -import Pantry (runPantryApp) -import Pantry.Internal (normalizeParents, makeTarRelative, hpackVersion) - -spec :: Spec -spec = do - describe "normalizeParents" $ do - let (!) :: HasCallStack => String -> Maybe String -> Spec - input ! output = - it input $ - let x = normalizeParents input - y = either (const Nothing) Just x - in y `shouldBe` output - - "/file/\\test" ! Nothing - "file/\\test" ! Just "file/\\test" - "/file/////\\test" ! Nothing - "file/////\\test" ! Just "file/\\test" - "file/test/" ! Just "file/test" - "/file/\\test////" ! Nothing - "/file/./test" ! Nothing - "file/./test" ! Just "file/test" - "/test/file/../bob/fred/" ! Nothing - "/test/file/../bob/fred" ! Nothing - "test/file/../bob/fred/" ! Just "test/bob/fred" - "test/file/../bob/fred" ! Just "test/bob/fred" - "test0/test1/file/../../bob/fred" ! Just "test0/bob/fred" - "../bob/fred" ! Nothing - "../bob/fred/" ! Nothing - "./bob/fred/" ! Just "bob/fred" - "./bob/fred" ! Just "bob/fred" - "./" ! Nothing - "./." ! Nothing - "/./" ! Nothing - "/" ! Nothing - "bob/fred/." ! Nothing - "//home" ! Nothing - "foobarbaz\\bin" ! Just "foobarbaz\\bin" - - describe "makeTarRelative" $ do - let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec - test base rel expected = - it (show (base, rel)) $ - either (const Nothing) Just (makeTarRelative base rel) - `shouldBe` expected - - test "foo/bar" "baz" $ Just "foo/baz" - test "foo" "bar" $ Just "bar" - test "foo" "/bar" Nothing - test "foo/" "bar" Nothing - - -- MSS 2018-08-23: Arguable whether this should be Nothing - -- instead, since we don't want any absolute paths. However, - -- that's really a concern for normalizeParents. Point being: if - -- you refactor in the future, and this turns into Nothing, that's - -- fine. - test "/foo" "bar" $ Just "/bar" - - describe "Parse HPack version" $ do - {- - let isVersion :: Version -> Bool - isVersion _ = True - -} - - it "Shipped hpack version" $ example $ do - _version <- runPantryApp hpackVersion - -- version `shouldSatisfy` isVersion - pure () - - -- it "External hpack version" $ do - -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion - -- version `shouldSatisfy` isVersion +module Pantry.InternalSpec (spec) where + +import Test.Hspec +import Pantry (runPantryApp) +import Pantry.Internal (normalizeParents, makeTarRelative, hpackVersion) + +spec :: Spec +spec = do + describe "normalizeParents" $ do + let (!) :: HasCallStack => String -> Maybe String -> Spec + input ! output = + it input $ + let x = normalizeParents input + y = either (const Nothing) Just x + in y `shouldBe` output + + "/file/\\test" ! Nothing + "file/\\test" ! Just "file/\\test" + "/file/////\\test" ! Nothing + "file/////\\test" ! Just "file/\\test" + "file/test/" ! Just "file/test" + "/file/\\test////" ! Nothing + "/file/./test" ! Nothing + "file/./test" ! Just "file/test" + "/test/file/../bob/fred/" ! Nothing + "/test/file/../bob/fred" ! Nothing + "test/file/../bob/fred/" ! Just "test/bob/fred" + "test/file/../bob/fred" ! Just "test/bob/fred" + "test0/test1/file/../../bob/fred" ! Just "test0/bob/fred" + "../bob/fred" ! Nothing + "../bob/fred/" ! Nothing + "./bob/fred/" ! Just "bob/fred" + "./bob/fred" ! Just "bob/fred" + "./" ! Nothing + "./." ! Nothing + "/./" ! Nothing + "/" ! Nothing + "bob/fred/." ! Nothing + "//home" ! Nothing + "foobarbaz\\bin" ! Just "foobarbaz\\bin" + + describe "makeTarRelative" $ do + let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec + test base rel expected = + it (show (base, rel)) $ + either (const Nothing) Just (makeTarRelative base rel) + `shouldBe` expected + + test "foo/bar" "baz" $ Just "foo/baz" + test "foo" "bar" $ Just "bar" + test "foo" "/bar" Nothing + test "foo/" "bar" Nothing + + -- MSS 2018-08-23: Arguable whether this should be Nothing + -- instead, since we don't want any absolute paths. However, + -- that's really a concern for normalizeParents. Point being: if + -- you refactor in the future, and this turns into Nothing, that's + -- fine. + test "/foo" "bar" $ Just "/bar" + + describe "Parse HPack version" $ do + {- + let isVersion :: Version -> Bool + isVersion _ = True + -} + + it "Shipped hpack version" $ example $ do + _version <- runPantryApp hpackVersion + -- version `shouldSatisfy` isVersion + pure () + + -- it "External hpack version" $ do + -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion + -- version `shouldSatisfy` isVersion diff --git a/test/Pantry/TreeSpec.hs b/test/Pantry/TreeSpec.hs --- a/test/Pantry/TreeSpec.hs +++ b/test/Pantry/TreeSpec.hs @@ -1,83 +1,83 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Pantry.TreeSpec (spec) where - -import Test.Hspec -import RIO -import Pantry -import qualified Pantry.SHA256 as SHA256 -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) - -spec :: Spec -spec = do - let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" - zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" - emptyPM = RawPackageMetadata - { rpmName = Nothing - , rpmVersion = Nothing - , rpmTreeKey = Nothing - } - mkArchive url = - RPLIArchive - RawArchive - { raLocation = ALUrl url - , raHash = Nothing - , raSize = Nothing - , raSubdir = "" - } - emptyPM - tarPL = mkArchive tarURL - zipPL = mkArchive zipURL - gitPL = - RPLIRepo - Repo - { repoUrl = "https://github.com/snoyberg/file-embed.git" - , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" - , repoType = RepoGit - , repoSubdir = "" - } - emptyPM - hgPL = - RPLIRepo - Repo - { repoUrl = "https://bitbucket.org/snoyberg/file-embed" - , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" - , repoType = RepoHg - , repoSubdir = "" - } - emptyPM - - it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageRaw tarPL - pair2 <- loadPackageRaw zipPL - liftIO $ pair2 `shouldBe` pair1 - it "archive and Git repo match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageRaw tarPL - pair2 <- loadPackageRaw gitPL - liftIO $ pair2 `shouldBe` pair1 - -- https://github.com/commercialhaskell/pantry/issues/26 - xit "archive and Hg repo match" $ asIO $ runPantryAppClean $ do - pair1 <- loadPackageRaw tarPL - pair2 <- loadPackageRaw hgPL - liftIO $ pair2 `shouldBe` pair1 - - it "5045 no cabal file" $ asIO $ runPantryAppClean $ do - let rpli = RPLIArchive archive rpm - packageName = mkPackageName "yaml" - version = mkVersion [0, 11, 1, 2] - archive = - RawArchive - { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" - , raHash = either impureThrow Just - $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" - , raSize = Just $ FileSize 94198 - , raSubdir = "yaml" - } - rpm = - RawPackageMetadata - { rpmName = Just packageName - , rpmVersion = Just version - , rpmTreeKey = Nothing - } - void $ loadCabalFileRawImmutable rpli +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.TreeSpec (spec) where + +import Test.Hspec +import RIO +import Pantry +import qualified Pantry.SHA256 as SHA256 +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) + +spec :: Spec +spec = do + let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" + zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" + emptyPM = RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + } + mkArchive url = + RPLIArchive + RawArchive + { raLocation = ALUrl url + , raHash = Nothing + , raSize = Nothing + , raSubdir = "" + } + emptyPM + tarPL = mkArchive tarURL + zipPL = mkArchive zipURL + gitPL = + RPLIRepo + Repo + { repoUrl = "https://github.com/snoyberg/file-embed.git" + , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" + , repoType = RepoGit + , repoSubdir = "" + } + emptyPM + hgPL = + RPLIRepo + Repo + { repoUrl = "https://bitbucket.org/snoyberg/file-embed" + , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" + , repoType = RepoHg + , repoSubdir = "" + } + emptyPM + + it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw zipPL + liftIO $ pair2 `shouldBe` pair1 + it "archive and Git repo match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw gitPL + liftIO $ pair2 `shouldBe` pair1 + -- https://github.com/commercialhaskell/pantry/issues/26 + xit "archive and Hg repo match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw hgPL + liftIO $ pair2 `shouldBe` pair1 + + it "5045 no cabal file" $ asIO $ runPantryAppClean $ do + let rpli = RPLIArchive archive rpm + packageName = mkPackageName "yaml" + version = mkVersion [0, 11, 1, 2] + archive = + RawArchive + { raLocation = ALUrl "https://github.com/snoyberg/yaml/archive/yaml-0.11.1.2.tar.gz" + , raHash = either impureThrow Just + $ SHA256.fromHexBytes "b8564e99c555e670ee487bbf92d03800d955f0e6e16333610ef46534548e0a3d" + , raSize = Just $ FileSize 94198 + , raSubdir = "yaml" + } + rpm = + RawPackageMetadata + { rpmName = Just packageName + , rpmVersion = Just version + , rpmTreeKey = Nothing + } + void $ loadCabalFileRawImmutable rpli diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs --- a/test/Pantry/TypesSpec.hs +++ b/test/Pantry/TypesSpec.hs @@ -1,229 +1,229 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - -module Pantry.TypesSpec - ( spec - ) where - -import Pantry.Internal.AesonExtended -import qualified Data.ByteString.Char8 as S8 -import qualified Data.Yaml as Yaml -import Distribution.Types.PackageName (mkPackageName) -import Distribution.Types.Version (mkVersion) -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import Pantry -import Pantry.Internal - ( Tree(..) - , TreeEntry(..) - , mkSafeFilePath - , parseTree - , renderTree - ) -import qualified Pantry.SHA256 as SHA256 -import RIO -import qualified RIO.Text as T -import Test.Hspec -import Text.RawString.QQ -import RIO.Time (Day (..)) - -hh :: HasCallStack => String -> Property -> Spec -hh name p = it name $ do - result <- check p - unless result $ throwString "Hedgehog property failed" :: IO () - -genBlobKey :: Gen BlobKey -genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) - -genSha256 :: Gen SHA256 -genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) - -samplePLIRepo :: ByteString -samplePLIRepo = - [r| -subdir: wai -cabal-file: - # This is ignored, only included to make sure we get no warnings - size: 1765 - sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 -name: wai -version: 3.2.1.2 -git: https://github.com/yesodweb/wai.git -pantry-tree: - size: 714 - sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 -commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 -|] - -samplePLIRepo2 :: ByteString -samplePLIRepo2 = - [r| -name: merkle-log -version: 0.1.0.0 -git: https://github.com/kadena-io/merkle-log.git -pantry-tree: - size: 615 - sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d -commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 -|] - -spec :: Spec -spec = do - describe "WantedCompiler" $ do - hh "parse/render works" $ property $ do - wc <- forAll $ - let ghc = WCGhc <$> genVersion - ghcjs = WCGhcjs <$> genVersion <*> genVersion - genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) - in Gen.choice [ghc, ghcjs] - let text = utf8BuilderToText $ display wc - case parseWantedCompiler text of - Left e -> throwIO e - Right actual -> liftIO $ actual `shouldBe` wc - - describe "Tree" $ do - hh "parse/render works" $ property $ do - tree <- forAll $ - let sfp = do - pieces <- Gen.list (Range.linear 1 10) sfpComponent - let combined = T.intercalate "/" pieces - case mkSafeFilePath combined of - Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces - Just sfp' -> pure sfp' - sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum - entry = TreeEntry - <$> genBlobKey - <*> Gen.choice (map pure [minBound..maxBound]) - in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) - let bs = renderTree tree - liftIO $ parseTree bs `shouldBe` Just tree - - describe "(Raw)SnapshotLayer" $ do - let parseSl :: String -> IO RawSnapshotLayer - parseSl str = case Yaml.decodeThrow . S8.pack $ str of - (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x - Nothing -> fail "Can't parse RawSnapshotLayer" - - it "parses snapshot using 'resolver'" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "resolver: lts-2.10\n" - rslParent `shouldBe` (RSLSynonym $ LTS 2 10) - - it "parses snapshot using 'snapshot'" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "snapshot: lts-2.10\n" - rslParent `shouldBe` (RSLSynonym $ LTS 2 10) - - it "throws if both 'resolver' and 'snapshot' are present" $ do - let go = parseSl $ - "name: 'test'\n" ++ - "resolver: lts-2.10\n" ++ - "snapshot: lts-2.10\n" - go `shouldThrow` anyException - - it "throws if both 'snapshot' and 'compiler' are not present" $ do - let go = parseSl "name: 'test'\n" - go `shouldThrow` anyException - - it "works if no 'snapshot' specified" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "compiler: ghc-8.0.1\n" - rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) - - hh "rendering the name of an LTS to JSON" $ property $ do - (major, minor) <- forAll $ (,) - <$> Gen.integral (Range.linear 1 10000) - <*> Gen.integral (Range.linear 1 10000) - liftIO $ - Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe` - Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) - - hh "rendering the name of a nightly to JSON" $ property $ do - days <- forAll $ Gen.integral $ Range.linear 1 10000000 - let day = ModifiedJulianDay days - liftIO $ - Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe` - Yaml.String (T.pack $ "nightly-" ++ show day) - it "FromJSON instance for PLIRepo" $ do - WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo - warnings `shouldBe` [] - pli <- resolvePaths Nothing unresolvedPli - let repoValue = - Repo - { repoSubdir = "wai" - , repoType = RepoGit - , repoCommit = - "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoUrl = "https://github.com/yesodweb/wai.git" - } - pantrySha = - SHA256.fromHexBytes - "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" - psha <- case pantrySha of - Right psha -> pure psha - _ -> fail "Failed decoding sha256" - let pkgValue = - PackageMetadata - { pmIdent = - PackageIdentifier - (mkPackageName "wai") - (mkVersion [3, 2, 1, 2]) - , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) - } - pli `shouldBe` PLIRepo repoValue pkgValue - - WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli - warnings2 `shouldBe` [] - reparsed' <- resolvePaths Nothing reparsed - reparsed' `shouldBe` pli - it "parseHackageText parses" $ do - let txt = - "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" - hsha = - SHA256.fromHexBytes - "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" - sha <- case hsha of - Right sha' -> pure sha' - _ -> fail "parseHackagetext: failed decoding the sha256" - let Right (pkgIdentifier, blobKey) = parseHackageText txt - blobKey `shouldBe` (BlobKey sha (FileSize 5058)) - pkgIdentifier `shouldBe` - PackageIdentifier - (mkPackageName "persistent") - (mkVersion [2, 8, 2]) - it "roundtripping a PLIRepo" $ do - WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 - warnings `shouldBe` [] - pli <- resolvePaths Nothing unresolvedPli - WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli - warnings2 `shouldBe` [] - pli2 <- resolvePaths Nothing unresolvedPli2 - pli2 `shouldBe` (pli :: PackageLocationImmutable) - - describe "completeSnapshotLocation" $ do - let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' = - do - txt `shouldBe` txt' - txt `shouldBe` txt'' - sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected" - - it "default location for nightly-2020-01-01" $ do - let sn = Nightly $ ModifiedJulianDay 58849 - loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn - sameUrl loc (defaultSnapshotLocation sn) - "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/1.yaml" - - it "default location for lts-15.1" $ do - let sn = LTS 15 1 - loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn - sameUrl loc (defaultSnapshotLocation sn) - "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml" +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Pantry.TypesSpec + ( spec + ) where + +import Pantry.Internal.AesonExtended +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Pantry +import Pantry.Internal + ( Tree(..) + , TreeEntry(..) + , mkSafeFilePath + , parseTree + , renderTree + ) +import qualified Pantry.SHA256 as SHA256 +import RIO +import qualified RIO.Text as T +import Test.Hspec +import Text.RawString.QQ +import RIO.Time (Day (..)) + +hh :: HasCallStack => String -> Property -> Spec +hh name p = it name $ do + result <- check p + unless result $ throwString "Hedgehog property failed" :: IO () + +genBlobKey :: Gen BlobKey +genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) + +genSha256 :: Gen SHA256 +genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) + +samplePLIRepo :: ByteString +samplePLIRepo = + [r| +subdir: wai +cabal-file: + # This is ignored, only included to make sure we get no warnings + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 +name: wai +version: 3.2.1.2 +git: https://github.com/yesodweb/wai.git +pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 +commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +|] + +samplePLIRepo2 :: ByteString +samplePLIRepo2 = + [r| +name: merkle-log +version: 0.1.0.0 +git: https://github.com/kadena-io/merkle-log.git +pantry-tree: + size: 615 + sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d +commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 +|] + +spec :: Spec +spec = do + describe "WantedCompiler" $ do + hh "parse/render works" $ property $ do + wc <- forAll $ + let ghc = WCGhc <$> genVersion + ghcjs = WCGhcjs <$> genVersion <*> genVersion + genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) + in Gen.choice [ghc, ghcjs] + let text = utf8BuilderToText $ display wc + case parseWantedCompiler text of + Left e -> throwIO e + Right actual -> liftIO $ actual `shouldBe` wc + + describe "Tree" $ do + hh "parse/render works" $ property $ do + tree <- forAll $ + let sfp = do + pieces <- Gen.list (Range.linear 1 10) sfpComponent + let combined = T.intercalate "/" pieces + case mkSafeFilePath combined of + Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces + Just sfp' -> pure sfp' + sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum + entry = TreeEntry + <$> genBlobKey + <*> Gen.choice (map pure [minBound..maxBound]) + in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) + let bs = renderTree tree + liftIO $ parseTree bs `shouldBe` Just tree + + describe "(Raw)SnapshotLayer" $ do + let parseSl :: String -> IO RawSnapshotLayer + parseSl str = case Yaml.decodeThrow . S8.pack $ str of + (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x + Nothing -> fail "Can't parse RawSnapshotLayer" + + it "parses snapshot using 'resolver'" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "resolver: lts-2.10\n" + rslParent `shouldBe` (RSLSynonym $ LTS 2 10) + + it "parses snapshot using 'snapshot'" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "snapshot: lts-2.10\n" + rslParent `shouldBe` (RSLSynonym $ LTS 2 10) + + it "throws if both 'resolver' and 'snapshot' are present" $ do + let go = parseSl $ + "name: 'test'\n" ++ + "resolver: lts-2.10\n" ++ + "snapshot: lts-2.10\n" + go `shouldThrow` anyException + + it "throws if both 'snapshot' and 'compiler' are not present" $ do + let go = parseSl "name: 'test'\n" + go `shouldThrow` anyException + + it "works if no 'snapshot' specified" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "compiler: ghc-8.0.1\n" + rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) + + hh "rendering the name of an LTS to JSON" $ property $ do + (major, minor) <- forAll $ (,) + <$> Gen.integral (Range.linear 1 10000) + <*> Gen.integral (Range.linear 1 10000) + liftIO $ + Yaml.toJSON (RSLSynonym $ LTS major minor) `shouldBe` + Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) + + hh "rendering the name of a nightly to JSON" $ property $ do + days <- forAll $ Gen.integral $ Range.linear 1 10000000 + let day = ModifiedJulianDay days + liftIO $ + Yaml.toJSON (RSLSynonym $ Nightly day) `shouldBe` + Yaml.String (T.pack $ "nightly-" ++ show day) + it "FromJSON instance for PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + let repoValue = + Repo + { repoSubdir = "wai" + , repoType = RepoGit + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoUrl = "https://github.com/yesodweb/wai.git" + } + pantrySha = + SHA256.fromHexBytes + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" + psha <- case pantrySha of + Right psha -> pure psha + _ -> fail "Failed decoding sha256" + let pkgValue = + PackageMetadata + { pmIdent = + PackageIdentifier + (mkPackageName "wai") + (mkVersion [3, 2, 1, 2]) + , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) + } + pli `shouldBe` PLIRepo repoValue pkgValue + + WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + reparsed' <- resolvePaths Nothing reparsed + reparsed' `shouldBe` pli + it "parseHackageText parses" $ do + let txt = + "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" + hsha = + SHA256.fromHexBytes + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" + sha <- case hsha of + Right sha' -> pure sha' + _ -> fail "parseHackagetext: failed decoding the sha256" + let Right (pkgIdentifier, blobKey) = parseHackageText txt + blobKey `shouldBe` (BlobKey sha (FileSize 5058)) + pkgIdentifier `shouldBe` + PackageIdentifier + (mkPackageName "persistent") + (mkVersion [2, 8, 2]) + it "roundtripping a PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + pli2 <- resolvePaths Nothing unresolvedPli2 + pli2 `shouldBe` (pli :: PackageLocationImmutable) + + describe "completeSnapshotLocation" $ do + let sameUrl (SLUrl txt _) (RSLUrl txt' _) txt'' = + do + txt `shouldBe` txt' + txt `shouldBe` txt'' + sameUrl _ _ _ = liftIO $ error "Snapshot synonym did not complete as expected" + + it "default location for nightly-2020-01-01" $ do + let sn = Nightly $ ModifiedJulianDay 58849 + loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn + sameUrl loc (defaultSnapshotLocation sn) + "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/1.yaml" + + it "default location for lts-15.1" $ do + let sn = LTS 15 1 + loc <- runPantryAppClean $ completeSnapshotLocation $ RSLSynonym sn + sameUrl loc (defaultSnapshotLocation sn) + "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/1.yaml" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}