pantry 0.5.6 → 0.5.7
raw patch · 36 files changed
+9792/−9743 lines, 36 filesdep ~Cabalnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: Cabal
API changes (from Hackage documentation)
+ Pantry: loadAndCompleteSnapshot' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Bool -> SnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
+ Pantry: loadAndCompleteSnapshotRaw' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Bool -> RawSnapshotLocation -> Map RawSnapshotLocation SnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
- Pantry.Internal.AesonExtended: class GToJSON' enc arity (f :: Type -> Type)
+ Pantry.Internal.AesonExtended: class GToJSON' enc arity (f :: TYPE LiftedRep -> Type)
- Pantry.Internal.AesonExtended: class ToJSON1 (f :: Type -> Type)
+ Pantry.Internal.AesonExtended: class ToJSON1 (f :: TYPE LiftedRep -> TYPE LiftedRep)
- Pantry.Internal.AesonExtended: class ToJSON2 (f :: Type -> Type -> Type)
+ Pantry.Internal.AesonExtended: class ToJSON2 (f :: TYPE LiftedRep -> TYPE LiftedRep -> TYPE LiftedRep)
Files
- ChangeLog.md +143/−126
- LICENSE +24/−24
- README.md +217/−217
- pantry.cabal +8/−8
- src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs +151/−151
- src/Pantry.hs +1869/−1839
- src/Pantry/Archive.hs +535/−535
- src/Pantry/Casa.hs +79/−79
- src/Pantry/HPack.hs +72/−72
- src/Pantry/HTTP.hs +101/−101
- src/Pantry/Hackage.hs +671/−671
- src/Pantry/Internal.hs +84/−84
- src/Pantry/Internal/AesonExtended.hs +238/−238
- src/Pantry/Internal/Companion.hs +78/−78
- src/Pantry/Internal/Stackage.hs +50/−50
- src/Pantry/Internal/StaticBytes.hs +238/−237
- src/Pantry/Repo.hs +296/−296
- src/Pantry/SHA256.hs +185/−185
- src/Pantry/SQLite.hs +103/−103
- src/Pantry/Storage.hs +1206/−1205
- src/Pantry/Tree.hs +58/−58
- src/Pantry/Types.hs +2404/−2404
- src/unix/System/IsWindows.hs +10/−10
- src/windows/System/IsWindows.hs +10/−10
- test/Pantry/ArchiveSpec.hs +103/−103
- test/Pantry/BuildPlanSpec.hs +119/−119
- test/Pantry/CabalSpec.hs +100/−100
- test/Pantry/CasaSpec.hs +95/−95
- test/Pantry/FileSpec.hs +18/−18
- test/Pantry/GlobalHintsSpec.hs +41/−41
- test/Pantry/HackageSpec.hs +23/−23
- test/Pantry/Internal/StaticBytesSpec.hs +76/−76
- test/Pantry/InternalSpec.hs +74/−74
- test/Pantry/TreeSpec.hs +83/−83
- test/Pantry/TypesSpec.hs +229/−229
- test/Spec.hs +1/−1
ChangeLog.md view
@@ -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.
LICENSE view
@@ -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.
README.md view
@@ -1,217 +1,217 @@-# pantry--[](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 + +[](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.cabal view
@@ -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 <https://github.com/commercialhaskell/pantry#readme>+description: Please see the README on GitHub at <https://github.com/commercialhaskell/pantry#readme> 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
src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs view
@@ -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 <https://github.com/snoyberg/http-client/issues/116>-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 <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>- 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 <https://github.com/snoyberg/http-client/issues/116> +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 <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html> + 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
src/Pantry.hs view
@@ -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--- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files>------ @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 +-- <https://tech.fpcomplete.com/blog/storing-generated-cabal-files> +-- +-- @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")
src/Pantry/Archive.hs view
@@ -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
src/Pantry/Casa.hs view
@@ -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
src/Pantry/HPack.hs view
@@ -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_
src/Pantry/HTTP.hs view
@@ -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'
src/Pantry/Hackage.hs view
@@ -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) + }
src/Pantry/Internal.hs view
@@ -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
src/Pantry/Internal/AesonExtended.hs view
@@ -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
src/Pantry/Internal/Companion.hs view
@@ -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)
src/Pantry/Internal/Stackage.hs view
@@ -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 + )
src/Pantry/Internal/StaticBytes.hs view
@@ -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
src/Pantry/Repo.hs view
@@ -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--- <https://github.com/commercialhaskell/stack/issues/3748>.-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 +-- <https://github.com/commercialhaskell/stack/issues/3748>. +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
src/Pantry/SHA256.hs view
@@ -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
src/Pantry/SQLite.hs view
@@ -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- -- <https://github.com/commercialhaskell/stack/issues/4471>- -- 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 + -- <https://github.com/commercialhaskell/stack/issues/4471> + -- 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
src/Pantry/Storage.hs view
@@ -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
src/Pantry/Tree.hs view
@@ -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
src/Pantry/Types.hs view
@@ -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--- <https://github.com/commercialhaskell/stack/issues/4471>, 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--- <https://github.com/commercialhaskell/stack/issues/4137>.------ @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--- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>.------ @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 +-- <https://github.com/commercialhaskell/stack/issues/4471>, 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 +-- <https://github.com/commercialhaskell/stack/issues/4137>. +-- +-- @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 +-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>. +-- +-- @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"
src/unix/System/IsWindows.hs view
@@ -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
src/windows/System/IsWindows.hs view
@@ -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
test/Pantry/ArchiveSpec.hs view
@@ -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"
test/Pantry/BuildPlanSpec.hs view
@@ -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
test/Pantry/CabalSpec.hs view
@@ -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
test/Pantry/CasaSpec.hs view
@@ -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 + }
test/Pantry/FileSpec.hs view
@@ -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
test/Pantry/GlobalHintsSpec.hs view
@@ -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
test/Pantry/HackageSpec.hs view
@@ -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`)
test/Pantry/Internal/StaticBytesSpec.hs view
@@ -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
test/Pantry/InternalSpec.hs view
@@ -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
test/Pantry/TreeSpec.hs view
@@ -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
test/Pantry/TypesSpec.hs view
@@ -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"
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}