summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorborsboom <>2019-07-11 19:54:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-11 19:54:00 (GMT)
commitaf8570e26b3e8a7d252b1ee52b4c22fa2735efa3 (patch)
treeac6d9e1ca4601aa871b5ce5e47aec78bfcb24996
version 0.1.0.00.1.0.0
-rw-r--r--ChangeLog.md5
-rw-r--r--LICENSE24
-rw-r--r--README.md218
-rw-r--r--attic/package-0.1.2.3.tar.gzbin0 -> 205 bytes
-rw-r--r--pantry.cabal222
-rw-r--r--src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs146
-rw-r--r--src/Pantry.hs1602
-rw-r--r--src/Pantry/Archive.hs531
-rw-r--r--src/Pantry/HPack.hs72
-rw-r--r--src/Pantry/HTTP.hs102
-rw-r--r--src/Pantry/Hackage.hs629
-rw-r--r--src/Pantry/Internal.hs83
-rw-r--r--src/Pantry/Internal/AesonExtended.hs219
-rw-r--r--src/Pantry/Internal/Companion.hs78
-rw-r--r--src/Pantry/Internal/Stackage.hs51
-rw-r--r--src/Pantry/Internal/StaticBytes.hs237
-rw-r--r--src/Pantry/Repo.hs198
-rw-r--r--src/Pantry/SHA256.hs185
-rw-r--r--src/Pantry/SQLite.hs101
-rw-r--r--src/Pantry/Storage.hs1101
-rw-r--r--src/Pantry/Tree.hs58
-rw-r--r--src/Pantry/Types.hs2274
-rw-r--r--src/unix/System/IsWindows.hs10
-rw-r--r--src/windows/System/IsWindows.hs10
-rw-r--r--test/Pantry/ArchiveSpec.hs104
-rw-r--r--test/Pantry/BuildPlanSpec.hs121
-rw-r--r--test/Pantry/CabalSpec.hs112
-rw-r--r--test/Pantry/FileSpec.hs18
-rw-r--r--test/Pantry/GlobalHintsSpec.hs41
-rw-r--r--test/Pantry/HackageSpec.hs23
-rw-r--r--test/Pantry/Internal/StaticBytesSpec.hs76
-rw-r--r--test/Pantry/InternalSpec.hs73
-rw-r--r--test/Pantry/TreeSpec.hs60
-rw-r--r--test/Pantry/TypesSpec.hs216
-rw-r--r--test/Spec.hs1
35 files changed, 9001 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..56de604
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Changelog for pantry
+
+## 0.1.0.0
+
+* Initial release
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f8dc1e5
--- /dev/null
+++ b/LICENSE
@@ -0,0 +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.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..4049a13
--- /dev/null
+++ b/README.md
@@ -0,0 +1,218 @@
+# pantry
+
+TODO: Add Travis and AppVeyor badges
+
+Content addressable Haskell package management, providing for secure,
+reproducible acquisition of Haskell package contents and metadata.
+
+## What is Pantry
+
+* A Haskell library, command line executable, storage specification, and
+ network protocol
+* Intended for content-addressable storage of Haskell packages
+* Allows non-centralized package storage
+* Primarily for use by Stackage and Stack, hopefully other tools as well
+
+## Goals
+
+* Efficient, distributed package storage for Haskell
+* Superset of existing storage mechanisms
+* Security via content addressable storage
+* Allow more Stackage-style snapshots to exist
+* Allow authors to bypass Hackage for uploads
+* Allow Stackage to create forks of packages on Hackage
+
+__TODO__
+
+Content below needs to be updated.
+
+* Support for hpack in PackageLocationImmutable?
+
+## Package definition
+
+Pantry defines the following concepts:
+
+* __Blob__: a raw byte sequence, identified by its key (SHA256 of the
+ contents)
+* __Tree entry__: contents of a single file (identified by blob key)
+ and whether or not it is executable.
+ * NOTE: existing package formats like tarballs support more
+ sophisticated options. We explicitly do not support those. If
+ such functionality is needed, fallback to those mechanism is
+ required.
+* __Tree__: mapping from relative path to a tree entry. Some basic
+ sanity rules apply to the paths: no `.` or `..` directory
+ components, no newlines in filepaths, does not begin with `/`, no
+ `\\` (we normalize to POSIX-style paths). A tree is identified by a
+ tree key (SHA256 of the tree's serialized format).
+* __Package__: a tree key for the package contents, package name,
+ version number, and cabal file blob key. Requirements: there must be
+ a single file with a `.cabal` file extension at the root of the
+ tree, and it must match the cabal file blob key. The cabal file must
+ be located at `pkgname.cabal`. Each tree can be in at most one
+ package, and therefore tree keys work as package keys too.
+
+Note that with the above, a tree key is all the information necessary
+to uniquely identify a package. However, including additional
+information (package name, version, cabal key) in config files may be
+useful for optimizations or user friendliness. If such extra
+information is ever included, it must be validated to concur with the
+package contents itself.
+
+### Package location
+
+Packages will optionally be sourced from some location:
+
+* __Hackage__ requires the package name, version number, and revision
+ number. Each revision of a package will end up with a different tree
+ key.
+* __Archive__ takes a URL pointing to a tarball (gzipped or not) or a
+ ZIP file. An implicit assumption is that archives remain immutable
+ over time. Use tree keys to verify this assumption. (Same applies to
+ Hackage for that matter.)
+* __Repository__ takes a repo type (Git or Mercurial), URL, and
+ commit. Assuming the veracity of the cryptographic hashes on the
+ repos, this should guarantee a unique set of files.
+
+In order to deal with _megarepos_ (repos and archives containing more
+than one package), there is also a subdirectory for the archive and
+repository cases. An empty subdir `""` would be the case for a
+standard repo/archive.
+
+In order to meet the rules of a package listed above, the following
+logic is applied to all three types above:
+
+* Find all of the files in the raw location, and represent as `Map
+ FilePath TreeEntry` (or equivalent).
+* Remove a wrapper directory. If _all_ filepaths in that `Map` are
+ contained within the same directory, strip it from all of the
+ paths. For example, if the paths are `foo/bar` and `foo/baz`, the
+ paths will be reduced to `bar` and `baz`.
+* After this wrapper is removed, then subdirectory logic is applied,
+ essentially applying `stripPrefix` to the filepaths. If the subdir
+ is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal`
+ and `yesod-bin/yesod-bin.cabal`, the only file remaining after
+ subdir stripping would be `yesod-bin.cabal`. Note that trailing
+ slashes must be handled appropriately, and that an empty subdir
+ string results in this step being a noop.
+
+The result of all of this is that, given one of the three package
+locations above, we can receive a tree key which will provide an
+installable package. That tree key will remain immutable.
+
+### How tooling refers to packages
+
+We'll get to the caching mechanism for Pantry below. However, the
+recommended approach for tooling is to support some kind of composite
+of the Pantry keys, parsed info, and raw package location. This allows
+for more efficient lookups when available, with a fallback when
+mirrors don't have the needed information.
+
+An example:
+
+```yaml
+extra-deps:
+- name: foobar
+ version: 1.2.3.4
+ pantry: deadbeef # tree key
+ cabal-file: 12345678 # blob key
+ archive: https://example.com/foobar-1.2.3.4.tar.gz
+```
+
+It is also recommended that tooling provide an easy way to generate
+such complete information from, e.g., just the URL of the tarball, and
+that upon reading information, hashes, package names, and version
+numbers are all checked for correctness.
+
+## Pantry caching
+
+One simplistic option for Pantry would be that, every time a piece of
+data is needed, Pantry downloads the necessary tarball/Git
+repo/etc. However, this would in practice be highly wasteful, since
+downloading Git repos and archives just to get a single cabal file
+(for plan construction purposes) is overkill. Instead, here's the
+basic idea for how caching works:
+
+* All data for Pantry can be stored in a SQL database. Local tools
+ like Stack will use an SQLite database. Servers will use PostgreSQL.
+* We'll define a network protocol (initially just HTTP, maybe
+ extending to something more efficient if desired) for querying blobs
+ and trees.
+* When a blob or tree is needed, it is first checked for in the local
+ SQLite cache. If it's not available there, a request to the Pantry
+ mirrors (configurable) will be made for the data. Since everything
+ is content addressable, it is safe to use untrusted mirrors.
+* If the data is not available in a mirror, and a location is
+ provided, the location will be downloaded and cached locally.
+
+We may also allow these Pantry mirrors to provide some kind of query
+interface to find out, e.g., the latest version of a package on
+Hackage. That's still TBD.
+
+## Example: resolving a package location
+
+To work through a full example, the following three stanzas are intended to
+have equivalent behavior:
+
+```yaml
+- archive: https://example.com/foobar-1.2.3.4.tar.gz
+
+- name: foobar
+ version: 1.2.3.4
+ pantry: deadbeef # tree key
+ cabal-file: 12345678 # blob key
+ archive: https://example.com/foobar-1.2.3.4.tar.gz
+
+- pantry: deadbeef
+
+```
+
+The question is: how does the first one (presumably what a user would want to
+enter) be resolved into the second and third? Pantry would follow this set of
+steps:
+
+* Download the tarball from the given URL
+* Place each file in the tarball into its store as a blob, getting a blob key
+ for each. The tarball is now represented as `Map FilePath BlobKey`
+* Perform the root directory stripping step, removing a shared path
+* Since there's no subdirectory: no subdirectory stripping would be performed
+* Serialize the `Map FilePath BlobKey` to a binary format and take its hash to
+ get a tree key
+* Store the tree in the store referenced by its tree key. In our example: the
+ tree key is `deadbeef`.
+* Ensure that the tree is a valid package by checking for a single cabal file
+ at the root. In our example, that's found in `foobar.cabal` with blob key
+ `12345678`.
+* Parse the cabal file and ensure that it is a valid cabal file, and that its
+ package name is `foobar`. Grab the version number (1.2.3.4).
+* We now know that tree key `deadbeef` is a valid package, and can refer to it
+ by tree key exclusively. However, including the other information allows us
+ to verify our assumptions, provide user-friendly readable data, and provide a
+ fallback if the package isn't in the Pantry cache.
+
+## More advanced content discovery
+
+There are three more advanced cases to consider:
+
+* Providing fall-back locations for content, such as out of concern for a
+ single URL being removed in the future
+* Closed corporate setups, where access to the general internet may either be
+ impossible or undesirable
+* Automatic discovery of missing content by hash
+
+The following extensions are possible to address these cases:
+
+* Instead of a single package location, provide a list of package locations
+ with fallback semantics.
+* Corporate environments will be encouraged to run a local Pantry mirror, and
+ configure clients like Stack to speak to these mirrors instead of the default
+ ones (or in addition to).
+* Provide some kind of federation protocol for Pantry where servers can
+ registry with each other and requests for content can be pinged to each
+ other.
+
+Providing override at the client level for Pantry mirror locations is a
+__MUST__. Making it easy to run in a corporate environment is a __SHOULD__.
+Providing the fallback package locations seems easy enough that we should
+include it initially, but falls under a __SHOULD__. The federated protocol
+should be added on-demand.
diff --git a/attic/package-0.1.2.3.tar.gz b/attic/package-0.1.2.3.tar.gz
new file mode 100644
index 0000000..a28a037
--- /dev/null
+++ b/attic/package-0.1.2.3.tar.gz
Binary files differ
diff --git a/pantry.cabal b/pantry.cabal
new file mode 100644
index 0000000..67cfd9f
--- /dev/null
+++ b/pantry.cabal
@@ -0,0 +1,222 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.1.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 90b9c809b0a38e3b8a7e330f7e0f3bc7a84c3e21412e271ff389c9b37eece3b8
+
+name: pantry
+version: 0.1.0.0
+synopsis: Content addressable Haskell package management
+description: Please see the README on Github at <https://github.com/commercialhaskell/stack/blob/master/subs/pantry/README.md>
+category: Development
+homepage: https://github.com/commercialhaskell/stack#readme
+bug-reports: https://github.com/commercialhaskell/stack/issues
+author: Michael Snoyman
+maintainer: michael@snoyman.com
+copyright: 2018-2019 FP Complete
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+ ChangeLog.md
+ attic/package-0.1.2.3.tar.gz
+
+source-repository head
+ type: git
+ location: https://github.com/commercialhaskell/stack
+
+library
+ exposed-modules:
+ Pantry
+ Pantry.SHA256
+ Pantry.Internal
+ Pantry.Internal.StaticBytes
+ Pantry.Internal.Stackage
+ Pantry.Internal.Companion
+ Pantry.Internal.AesonExtended
+ other-modules:
+ Hackage.Security.Client.Repository.HttpLib.HttpClient
+ Pantry.Archive
+ Pantry.HTTP
+ Pantry.HPack
+ Pantry.Hackage
+ Pantry.Repo
+ Pantry.SQLite
+ Pantry.Storage
+ Pantry.Tree
+ Pantry.Types
+ hs-source-dirs:
+ src/
+ default-extensions: MonadFailDesugaring
+ ghc-options: -Wall
+ build-depends:
+ Cabal
+ , aeson
+ , ansi-terminal
+ , array
+ , base >=4.10 && <5
+ , base-orphans
+ , base64-bytestring
+ , bytestring
+ , conduit
+ , conduit-extra
+ , containers
+ , contravariant
+ , cryptonite
+ , cryptonite-conduit
+ , deepseq
+ , digest
+ , directory
+ , filelock
+ , filepath
+ , generic-deriving
+ , ghc-prim
+ , hackage-security
+ , hashable
+ , hpack
+ , http-client
+ , http-client-tls
+ , http-conduit
+ , http-download
+ , http-types
+ , integer-gmp
+ , memory
+ , mono-traversable
+ , mtl
+ , network
+ , network-uri
+ , path
+ , path-io
+ , persistent
+ , persistent-sqlite
+ , persistent-template
+ , primitive
+ , resourcet
+ , rio
+ , rio-orphans
+ , rio-prettyprint
+ , safe
+ , syb
+ , tar-conduit
+ , template-haskell
+ , text
+ , text-metrics
+ , th-lift
+ , th-lift-instances
+ , th-orphans
+ , th-reify-many
+ , th-utilities
+ , time
+ , transformers
+ , unix-compat
+ , unliftio
+ , unordered-containers
+ , vector
+ , yaml
+ , zip-archive
+ if os(windows)
+ other-modules:
+ System.IsWindows
+ hs-source-dirs:
+ src/windows/
+ else
+ other-modules:
+ System.IsWindows
+ hs-source-dirs:
+ src/unix/
+ default-language: Haskell2010
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ other-modules:
+ Pantry.ArchiveSpec
+ Pantry.BuildPlanSpec
+ Pantry.CabalSpec
+ Pantry.FileSpec
+ Pantry.GlobalHintsSpec
+ Pantry.HackageSpec
+ Pantry.Internal.StaticBytesSpec
+ Pantry.InternalSpec
+ Pantry.TreeSpec
+ Pantry.TypesSpec
+ Paths_pantry
+ hs-source-dirs:
+ test
+ default-extensions: MonadFailDesugaring
+ ghc-options: -Wall
+ build-depends:
+ Cabal
+ , QuickCheck
+ , aeson
+ , ansi-terminal
+ , array
+ , base >=4.10 && <5
+ , base-orphans
+ , base64-bytestring
+ , bytestring
+ , conduit
+ , conduit-extra
+ , containers
+ , contravariant
+ , cryptonite
+ , cryptonite-conduit
+ , deepseq
+ , digest
+ , directory
+ , exceptions
+ , filelock
+ , filepath
+ , generic-deriving
+ , ghc-prim
+ , hackage-security
+ , hashable
+ , hedgehog
+ , hpack
+ , hspec
+ , http-client
+ , http-client-tls
+ , http-conduit
+ , http-download
+ , http-types
+ , integer-gmp
+ , memory
+ , mono-traversable
+ , mtl
+ , network
+ , network-uri
+ , pantry
+ , path
+ , path-io
+ , persistent
+ , persistent-sqlite
+ , persistent-template
+ , primitive
+ , raw-strings-qq
+ , resourcet
+ , rio
+ , rio-orphans
+ , rio-prettyprint
+ , safe
+ , syb
+ , tar-conduit
+ , template-haskell
+ , text
+ , text-metrics
+ , th-lift
+ , th-lift-instances
+ , th-orphans
+ , th-reify-many
+ , th-utilities
+ , time
+ , transformers
+ , unix-compat
+ , unliftio
+ , unordered-containers
+ , vector
+ , yaml
+ , zip-archive
+ default-language: Haskell2010
diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs
new file mode 100644
index 0000000..9a2a002
--- /dev/null
+++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs
@@ -0,0 +1,146 @@
+-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- Taken from
+-- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client
+-- to avoid extra dependencies
+module Hackage.Security.Client.Repository.HttpLib.HttpClient (
+ 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
+import qualified Hackage.Security.Util.Lens as Lens
+
+{-------------------------------------------------------------------------------
+ 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 =
+ HTTP.setRequestHeaders (trOpt disallowCompressionByDefault opts)
+ where
+ trOpt :: [(HTTP.HeaderName, [ByteString])]
+ -> [HttpRequestHeader]
+ -> [HTTP.Header]
+ trOpt acc [] =
+ concatMap 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 x y = Lens.modify (Lens.lookupM x) (++ y)
+
+-- | Extract the response headers
+getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]
+getResponseHeaders response = concat [
+ [ HttpResponseAcceptRangesBytes
+ | (hAcceptRanges, "bytes") `elem` headers
+ ]
+ ]
+ where
+ headers = HTTP.getResponseHeaders response
diff --git a/src/Pantry.hs b/src/Pantry.hs
new file mode 100644
index 0000000..6d77a9a
--- /dev/null
+++ b/src/Pantry.hs
@@ -0,0 +1,1602 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# 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
+ , HasPantryConfig (..)
+ , withPantryConfig
+ , HpackExecutable (..)
+
+ -- ** Convenience
+ , PantryApp
+ , runPantryApp
+ , runPantryAppClean
+ , 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 (..)
+ , withRepo
+
+ -- ** Package location
+ , RawPackageLocation (..)
+ , PackageLocation (..)
+ , toRawPL
+ , RawPackageLocationImmutable (..)
+ , PackageLocationImmutable (..)
+
+ -- ** Snapshots
+ , RawSnapshotLocation (..)
+ , SnapshotLocation (..)
+ , toRawSL
+ , RawSnapshot (..)
+ , Snapshot (..)
+ , RawSnapshotPackage (..)
+ , SnapshotPackage (..)
+ , RawSnapshotLayer (..)
+ , SnapshotLayer (..)
+ , toRawSnapshotLayer
+ , WantedCompiler (..)
+
+ -- * Loading values
+ , resolvePaths
+ , loadPackageRaw
+ , loadPackage
+ , loadRawSnapshotLayer
+ , loadSnapshotLayer
+ , loadSnapshot
+ , loadAndCompleteSnapshot
+ , loadAndCompleteSnapshotRaw
+ , CompletedSL (..)
+ , CompletedPLI (..)
+ , addPackagesToSnapshot
+ , AddPackagesConfig (..)
+
+ -- * Completion functions
+ , completePackageLocation
+ , completeSnapshotLayer
+ , completeSnapshotLocation
+
+ -- * Parsers
+ , parseWantedCompiler
+ , parseRawSnapshotLocation
+ , parsePackageIdentifierRevision
+ , parseHackageText
+
+ -- ** Cabal values
+ , parsePackageIdentifier
+ , parsePackageName
+ , parsePackageNameThrowing
+ , parseFlagName
+ , parseVersion
+ , parseVersionThrowing
+
+ -- * Stackage snapshots
+ , ltsSnapshotLocation
+ , nightlySnapshotLocation
+
+ -- * 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 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.Repo
+import qualified Pantry.SHA256 as SHA256
+import Pantry.Storage hiding (TreeEntry, PackageName, Version)
+import Pantry.Tree
+import Pantry.Types
+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.Common (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)
+
+-- | 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
+ -> (PantryConfig -> RIO env a)
+ -- ^ What to do with the config
+ -> RIO env a
+withPantryConfig root hsc he count 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
+ }
+
+-- | Default 'HackageSecurityConfig' value using the official Hackage server.
+--
+-- @since 0.1.0.0
+defaultHackageSecurityConfig :: HackageSecurityConfig
+defaultHackageSecurityConfig = HackageSecurityConfig
+ { hscKeyIds =
+ [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
+ , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
+ , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"
+ , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"
+ , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
+ , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
+ , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"
+ , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"
+ , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
+ ]
+ , hscKeyThreshold = 3
+ , hscDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/"
+ , 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')
+
+fetchTreeKeys
+ :: (HasPantryConfig env, HasLogFunc env, Foldable f)
+ => f TreeKey
+ -> RIO env ()
+fetchTreeKeys _ =
+ logWarn "Network caching not yet implemented!" -- TODO pantry wire
+
+-- | 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 $ map getTreeKey $ 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.
+--
+-- 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
+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
+ let foundCabalKey = bsToBlobKey bs
+ (_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
+ , pmCabal = cfHash
+ }
+ PLIArchive _ pm' -> pm'
+ PLIRepo _ pm' -> pm'
+ let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing
+ foundCabalKey (gpdPackageIdentifier gpd)
+ PackageIdentifier name ver = pmIdent pm
+ maybe (throwIO exc) pure $ do
+ guard $ name == gpdPackageName gpd
+ guard $ ver == gpdVersion gpd
+ guard $ pmCabal pm == foundCabalKey
+ 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
+ let foundCabalKey = bsToBlobKey bs
+ (_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
+ , rpmCabal =
+ case cfi of
+ CFIHash sha (Just size) -> Just $ BlobKey sha size
+ _ -> Nothing
+ }
+ RPLIArchive _ rpm' -> rpm'
+ RPLIRepo _ rpm' -> rpm'
+ let exc = MismatchedPackageMetadata loc rpm Nothing foundCabalKey (gpdPackageIdentifier gpd)
+ maybe (throwIO exc) pure $ do
+ guard $ maybe True (== gpdPackageName gpd) (rpmName rpm)
+ guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm)
+ guard $ maybe True (== foundCabalKey) (rpmCabal 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
+ -- TODO when we have pantry wire, try downloading
+ 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
+ -- TODO when we have pantry wire, try downloading
+ 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 (PLIHackage ident cfHash tree) =
+ htrPackage <$> getHackageTarball (pirForHash ident cfHash) (Just tree)
+loadPackage pli@(PLIArchive archive pm) = getArchivePackage (toRawPLI pli) (toRawArchive archive) (toRawPM pm)
+loadPackage (PLIRepo repo pm) = getRepo repo (toRawPM pm)
+
+-- | Load a 'Package' from a 'RawPackageLocationImmutable'.
+--
+-- @since 0.1.0.0
+loadPackageRaw
+ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => RawPackageLocationImmutable
+ -> RIO env Package
+loadPackageRaw (RPLIHackage pir mtree) = htrPackage <$> getHackageTarball pir mtree
+loadPackageRaw rpli@(RPLIArchive archive pm) = getArchivePackage rpli archive pm
+loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm
+
+-- | 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 PackageLocationImmutable
+completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) =
+ pure $ PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk
+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 $ PLIHackage (PackageIdentifier name version) cfKey treeKey'
+completePackageLocation pl@(RPLIArchive archive rpm) = do
+ -- getArchive checks archive and package metadata
+ (sha, size, package) <- getArchive pl archive rpm
+ let RawArchive loc _ _ subdir = archive
+ pure $ PLIArchive (Archive loc sha size subdir) (packagePM package)
+completePackageLocation pl@(RPLIRepo repo rpm) = do
+ unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo
+ PLIRepo repo <$> completePM pl rpm
+ where
+ isSHA1 t = T.length t == 40 && T.all isHexDigit t
+
+completePM
+ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => RawPackageLocationImmutable
+ -> RawPackageMetadata
+ -> RIO env PackageMetadata
+completePM plOrig rpm@(RawPackageMetadata mn mv mtk mc)
+ | Just n <- mn, Just v <- mv, Just tk <- mtk, Just c <- mc =
+ pure $ PackageMetadata (PackageIdentifier n v) tk c
+ | otherwise = do
+ pm <- packagePM <$> loadPackageRaw plOrig
+ 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) &&
+ isSame (pmCabal pm) (rpmCabal rpm)
+ if allSame
+ then pure pm
+ else throwIO $ CompletePackageMetadataMismatch plOrig pm
+
+packagePM :: Package -> PackageMetadata
+packagePM package = PackageMetadata
+ { pmIdent = packageIdent package
+ , pmTreeKey = packageTreeKey package
+ , pmCabal = teBlob $ case packageCabalEntry package of
+ PCCabalFile cfile -> cfile
+ PCHpack hfile -> phGenerated hfile
+ }
+
+-- | 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)
+
+-- | Fill in optional fields in a 'SnapshotLayer' for more reproducible builds.
+--
+-- @since 0.1.0.0
+completeSnapshotLayer
+ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => RawSnapshotLayer
+ -> RIO env SnapshotLayer
+completeSnapshotLayer rsnapshot = do
+ parent' <- completeSnapshotLocation $ rslParent rsnapshot
+ pls <- traverseConcurrently completePackageLocation $ rslLocations rsnapshot
+ pure SnapshotLayer
+ { slParent = parent'
+ , slLocations = pls
+ , slCompiler= rslCompiler rsnapshot
+ , slDropPackages = rslDropPackages rsnapshot
+ , slFlags = rslFlags rsnapshot
+ , slHidden = rslHidden rsnapshot
+ , slGhcOptions = rslGhcOptions rsnapshot
+ , slPublishTime = rslPublishTime rsnapshot
+ }
+
+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
+
+traverseConcurrently
+ :: (HasPantryConfig env, Traversable t)
+ => (a -> RIO env b) -- ^ action to perform
+ -> t a -- ^ input values
+ -> RIO env (t b)
+traverseConcurrently f t0 = do
+ cnt <- view $ pantryConfigL.to pcConnectionCount
+ traverseConcurrentlyWith cnt f t0
+
+-- | Like 'traverse', but does things on
+-- up to N separate threads at once.
+traverseConcurrentlyWith
+ :: (MonadUnliftIO m, Traversable t)
+ => Int -- ^ concurrent workers
+ -> (a -> m b) -- ^ action to perform
+ -> t a -- ^ input values
+ -> m (t b)
+traverseConcurrentlyWith count f t0 = do
+ (queue, t1) <- atomically $ do
+ queueDList <- newTVar id
+ t1 <- for t0 $ \x -> do
+ res <- newEmptyTMVar
+ modifyTVar queueDList (. ((x, res):))
+ pure $ atomically $ takeTMVar res
+ dlist <- readTVar queueDList
+ queue <- newTVar $ dlist []
+ pure (queue, t1)
+
+ replicateConcurrently_ count $
+ fix $ \loop -> join $ atomically $ do
+ toProcess <- readTVar queue
+ case toProcess of
+ [] -> pure (pure ())
+ ((x, res):rest) -> do
+ writeTVar queue rest
+ pure $ do
+ y <- f x
+ atomically $ putTMVar res y
+ loop
+ sequence t1
+
+-- | 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
+ (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 PackageLocationImmutable
+cachedSnapshotCompletePackageLocation cachePackages rpli = do
+ let xs = Map.lookup rpli cachePackages
+ case xs of
+ Nothing -> completePackageLocation rpli
+ Just x -> pure 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
+ complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc
+ 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))
+
+-- | 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 -> return bs
+ Nothing -> loadWithCheck url (Just bkey)
+
+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
+ 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 f = runSimpleApp $ do
+ sa <- ask
+ stack <- getAppUserDataDirectory "stack"
+ root <- parseAbsDir $ stack FilePath.</> "pantry"
+ withPantryConfig
+ root
+ defaultHackageSecurityConfig
+ HpackBundled
+ 8
+ $ \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
+ $ \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
+ scId <- withStorage $ getSnapshotCacheId hash
+ packageModules <- getModuleMapping
+ logWarn "Populating snapshot module name cache"
+ withStorage $ storeSnapshotModuleCache scId packageModules
+ return scId
+ Just scId -> pure scId
+ f $ withStorage . loadExposedModulePackages cacheId
diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs
new file mode 100644
index 0000000..080f380
--- /dev/null
+++ b/src/Pantry/Archive.hs
@@ -0,0 +1,531 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- | Logic for loading up trees from HTTPS archives.
+module Pantry.Archive
+ ( getArchivePackage
+ , getArchive
+ , getArchiveKey
+ , fetchArchivesRaw
+ , fetchArchives
+ ) 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 [
+ let PackageIdentifier nm ver = pmIdent pm
+ rpm = RawPackageMetadata (Just nm) (Just ver) (Just $ pmTreeKey pm) (Just $ pmCabal pm)
+ ra = RawArchive (archiveLocation a) (Just $ archiveHash a) (Just $ archiveSize a) (archiveSubdir a)
+ in (ra, rpm)
+ | (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
+
+thd3 :: (a, b, c) -> c
+thd3 (_, _, z) = z
+
+getArchivePackage
+ :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
+ => RawPackageLocationImmutable -- ^ for exceptions
+ -> RawArchive
+ -> RawPackageMetadata
+ -> RIO env Package
+getArchivePackage rpli archive rpm = thd3 <$> getArchive rpli archive rpm
+
+getArchive
+ :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack)
+ => RawPackageLocationImmutable -- ^ for exceptions
+ -> RawArchive
+ -> RawPackageMetadata
+ -> RIO env (SHA256, FileSize, Package)
+getArchive rpli archive rpm = do
+ -- Check if the value is in the archive, and use it if possible
+ mcached <- loadCache rpli archive
+ cached@(_, _, pa) <-
+ case mcached of
+ Just stored -> pure stored
+ -- Not in the archive. Load the archive. Completely ignore the
+ -- PackageMetadata for now, we'll check that the Package
+ -- info matches next.
+ Nothing -> withArchiveLoc archive $ \fp sha size -> do
+ pa <- 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)
+
+ 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
+ logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash"
+ logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size
+ logWarn "For security and reproducibility, please add a hash and file size to your configuration"
+ ALFilePath _ -> pure ()
+ fmap (sha, size,) <$> loadFromCache tid
+ Just sha'
+ | sha == sha' ->
+ case msize of
+ Nothing -> do
+ case loc of
+ ALUrl url -> do
+ logWarn $ "Archive from " <> display url <> " does not specify a size"
+ logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size
+ ALFilePath _ -> pure ()
+ fmap (sha, size,) <$> loadFromCache tid
+ Just size'
+ | size == size' -> fmap (sha, size,) <$> loadFromCache tid
+ | otherwise -> do
+
+ 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
+ pkgCabal = case packageCabalEntry pa of
+ PCCabalFile tentry -> tentry
+ PCHpack phpack -> phGenerated phpack
+ err = MismatchedPackageMetadata
+ pl
+ pm
+ (Just (packageTreeKey pa))
+ (teBlob pkgCabal)
+ (packageIdent pa)
+ 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)
+ , test (rpmCabal pm) (teBlob pkgCabal)
+ ]
+
+ 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
+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) <-
+ foldArchive loc fp at mempty $ \m me ->
+ if mePath me `Set.member` toSave
+ then do
+ bs <- mconcat <$> sinkList
+ (_, blobKey) <- lift $ withStorage $ storeBlob bs
+ pure $ Map.insert (mePath me) blobKey m
+ else pure m
+ tree <- fmap (TreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) ->
+ case Map.lookup (seSource se) blobs of
+ Nothing -> error $ "Impossible: blob not found for: " ++ seSource se
+ Just blobKey -> pure (sfp, TreeEntry blobKey (seType se))
+ -- parse the cabal file and ensure it has the right name
+ buildFile <- findCabalOrHpackFile rpli 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 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 = tree
+ , packageCabalEntry = packageCabal
+ , packageIdent = ident
+ }
+
+-- | Find all of the files in the Map with the given directory as a
+-- prefix. Directory is given without trailing slash. Returns the
+-- suffix after stripping the given prefix.
+findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)]
+findWithPrefix dir = mapMaybe go . Map.toList
+ where
+ prefix = dir ++ "/"
+ go (x, y) = (, y) <$> List.stripPrefix prefix x
+
+findCabalOrHpackFile
+ :: MonadThrow m
+ => RawPackageLocationImmutable -- ^ for exceptions
+ -> Tree
+ -> m BuildFile
+findCabalOrHpackFile loc (TreeMap m) = do
+ let isCabalFile (sfp, _) =
+ let txt = unSafeFilePath sfp
+ in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt)
+ isHpackFile (sfp, _) =
+ let txt = unSafeFilePath sfp
+ in T.pack (Hpack.packageConfig) == txt
+ isBFCabal (BFCabal _ _) = True
+ isBFCabal _ = False
+ sfpBuildFile (BFCabal sfp _) = sfp
+ sfpBuildFile (BFHpack _) = hpackSafeFilePath
+ toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs)
+ then Just $ BFCabal sfp te
+ else Nothing
+ hpFile = if (isHpackFile xs)
+ then Just $ BFHpack te
+ else Nothing
+ in cbFile <|> hpFile
+ case mapMaybe toBuildFile $ Map.toList m of
+ [] -> throwM $ TreeWithoutCabalFile loc
+ [bfile] -> pure bfile
+ xs -> case (filter isBFCabal xs) of
+ [] -> throwM $ TreeWithoutCabalFile loc
+ [bfile] -> pure bfile
+ xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs'
+
+-- | If all files have a shared prefix, strip it off
+stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)]
+stripCommonPrefix [] = []
+stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do
+ let firstDir = takeWhile (/= '/') firstFP
+ guard $ not $ null firstDir
+ let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp
+ stripCommonPrefix <$> traverse strip pairs
+
+-- | Take us down to the specified subdirectory
+takeSubdir
+ :: Text -- ^ subdir
+ -> [(FilePath, a)] -- ^ files after stripping common prefix
+ -> [(Text, a)]
+takeSubdir subdir = mapMaybe $ \(fp, a) -> do
+ stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp
+ Just (T.intercalate "/" stripped, a)
+ where
+ splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/"
+ subdirs = splitDirs subdir
diff --git a/src/Pantry/HPack.hs b/src/Pantry/HPack.hs
new file mode 100644
index 0000000..5231828
--- /dev/null
+++ b/src/Pantry/HPack.hs
@@ -0,0 +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_
diff --git a/src/Pantry/HTTP.hs b/src/Pantry/HTTP.hs
new file mode 100644
index 0000000..a3ebb6b
--- /dev/null
+++ b/src/Pantry/HTTP.hs
@@ -0,0 +1,102 @@
+{-# 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,
+ setRequestHeaders)
+import qualified Network.HTTP.Simple as HTTP hiding (withResponse)
+import Network.HTTP.Types as Export (Header, HeaderName,
+ Status, hCacheControl,
+ hRange, ok200,
+ partialContent206,
+ statusCode)
+import qualified Pantry.SHA256 as SHA256
+import Pantry.Types
+import RIO
+import qualified RIO.ByteString as B
+import qualified RIO.Text as T
+
+setUserAgent :: Request -> Request
+setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"]
+
+withResponse
+ :: MonadUnliftIO m
+ => HTTP.Request
+ -> (Response BodyReader -> m a)
+ -> m a
+withResponse req inner = withRunInIO $ \run -> do
+ manager <- getGlobalManager
+ HTTP.withResponse (setUserAgent req) manager (run . inner)
+
+httpSink
+ :: MonadUnliftIO m
+ => Request
+ -> (Response () -> ConduitT ByteString Void m a)
+ -> m a
+httpSink req inner = HTTP.httpSink (setUserAgent req) inner
+
+httpSinkChecked
+ :: MonadUnliftIO m
+ => Text
+ -> Maybe SHA256
+ -> Maybe FileSize
+ -> ConduitT ByteString Void m a
+ -> m (SHA256, FileSize, a)
+httpSinkChecked url msha msize sink = do
+ req <- liftIO $ parseUrlThrow $ T.unpack url
+ httpSink req $ const $ getZipSink $ (,,)
+ <$> ZipSink (checkSha msha)
+ <*> ZipSink (checkSize msize)
+ <*> ZipSink sink
+ where
+ checkSha mexpected = do
+ actual <- SHA256.sinkHash
+ for_ mexpected $ \expected -> unless (actual == expected) $
+ throwIO $ DownloadInvalidSHA256 url Mismatch
+ { mismatchExpected = expected
+ , mismatchActual = actual
+ }
+ pure actual
+ checkSize mexpected =
+ loop 0
+ where
+ loop accum = do
+ mbs <- await
+ case mbs of
+ Nothing ->
+ case mexpected of
+ Just (FileSize expected) | expected /= accum ->
+ throwIO $ DownloadInvalidSize url Mismatch
+ { mismatchExpected = FileSize expected
+ , mismatchActual = FileSize accum
+ }
+ _ -> pure (FileSize accum)
+ Just bs -> do
+ let accum' = accum + fromIntegral (B.length bs)
+ case mexpected of
+ Just (FileSize expected)
+ | accum' > expected ->
+ throwIO $ DownloadTooLarge url Mismatch
+ { mismatchExpected = FileSize expected
+ , mismatchActual = FileSize accum'
+ }
+ _ -> loop accum'
diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs
new file mode 100644
index 0000000..fc02529
--- /dev/null
+++ b/src/Pantry/Hackage.hs
@@ -0,0 +1,629 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Pantry.Hackage
+ ( updateHackageIndex
+ , forceUpdateHackageIndex
+ , DidUpdateOccur (..)
+ , RequireHackageIndex (..)
+ , hackageIndexTarballL
+ , getHackageTarball
+ , getHackageTarballKey
+ , getHackageCabalFile
+ , getHackagePackageVersions
+ , getHackagePackageVersionRevisions
+ , getHackageTypoCorrections
+ , UsePreferredVersions (..)
+ , HackageTarballResult(..)
+ ) where
+
+import RIO
+import RIO.Process
+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 System.IO (SeekMode (..))
+import qualified Data.List.NonEmpty as NE
+import Data.Text.Metrics (damerauLevenshtein)
+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 -> withStorage $ loadBlobBySHA sha
+ CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver)
+ CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver)
+
+-- | 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 <-
+ getArchivePackage
+ 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
+ , rpmCabal = Nothing -- cabal file in the tarball may be different!
+ }
+ case packageTree package of
+ TreeMap m -> do
+ let ft =
+ case packageCabalEntry package of
+ PCCabalFile (TreeEntry _ ft') -> ft'
+ _ -> error "Impossible: Hackage does not support hpack"
+ cabalEntry = TreeEntry cabalFileKey ft
+ tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m
+ ident = PackageIdentifier name ver
+ cabalBS <-
+ withStorage $ do
+ let BlobKey sha' _ = cabalFileKey
+ mcabalBS <- loadBlobBySHA sha'
+ case mcabalBS of
+ Nothing ->
+ error $
+ "Invariant violated, cabal file key: " ++ show cabalFileKey
+ Just bid -> loadBlobById bid
+ (_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 = tree'
+ , packageIdent = ident
+ , packageCabalEntry = PCCabalFile cabalEntry
+ }
+ , htrFreshPackageInfo = Just (gpd, tid)
+ }
diff --git a/src/Pantry/Internal.hs b/src/Pantry/Internal.hs
new file mode 100644
index 0000000..ab9a47b
--- /dev/null
+++ b/src/Pantry/Internal.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Exposed for testing, do not use!
+module Pantry.Internal
+ ( parseTree
+ , renderTree
+ , Tree (..)
+ , TreeEntry (..)
+ , 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 [] = []
+ loop (_:"..":rest) = loop rest
+ loop (x:xs) = x : loop xs
+
+ case loop c2 of
+ [] -> Left "no non-empty components"
+ c' -> Right $ T.unpack $ T.intercalate "/" c'
+
+-- | Following tar file rules (Unix file paths only), make the second
+-- file relative to the first file.
+makeTarRelative
+ :: FilePath -- ^ base file
+ -> FilePath -- ^ relative part
+ -> Either String FilePath
+makeTarRelative _ ('/':_) = Left "absolute path found"
+makeTarRelative base rel =
+ case reverse base of
+ [] -> Left "cannot have empty base"
+ '/':_ -> Left "base cannot be a directory"
+ _:rest -> Right $
+ case dropWhile (/= '/') rest of
+ '/':rest' -> reverse rest' ++ '/' : rel
+ rest' -> assert (null rest') rel
diff --git a/src/Pantry/Internal/AesonExtended.hs b/src/Pantry/Internal/AesonExtended.hs
new file mode 100644
index 0000000..c0a45d1
--- /dev/null
+++ b/src/Pantry/Internal/AesonExtended.hs
@@ -0,0 +1,219 @@
+{-# 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.HashMap.Strict as HashMap
+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)
+
+-- | Extends @.:@ warning to include field name.
+(.:) :: FromJSON a => Object -> Text -> Parser a
+(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: 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..:? 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 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 (HashMap.keys obj))
+ (wpmExpectedFields w))
+ return
+ (WithJSONWarnings a
+ (wpmWarnings w ++
+ case unrecognizedFields of
+ [] -> []
+ _ -> [JSONUnrecognizedFields expected unrecognizedFields]))
+
+-- | Convert a 'WarningParser' to a 'Parser'.
+unWarningParser :: WarningParser a -> Parser a
+unWarningParser wp = do
+ (a,_) <- runWriterT wp
+ return a
+
+-- | Log JSON warnings.
+logJSONWarnings
+ :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
+ => FilePath -> [JSONWarning] -> m ()
+logJSONWarnings fp =
+ mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w))
+
+-- | Handle warnings in a sub-object.
+jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a
+jsonSubWarnings f = do
+ WithJSONWarnings result warnings <- f
+ tell
+ (mempty
+ { wpmWarnings = warnings
+ })
+ return result
+
+-- | Handle warnings in a @Traversable@ of sub-objects.
+jsonSubWarningsT
+ :: Traversable t
+ => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
+jsonSubWarningsT f =
+ mapM (jsonSubWarnings . return) =<< f
+
+-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
+jsonSubWarningsTT
+ :: (Traversable t, Traversable u)
+ => WarningParser (u (t (WithJSONWarnings a)))
+ -> WarningParser (u (t a))
+jsonSubWarningsTT f =
+ mapM (jsonSubWarningsT . return) =<< f
+
+-- Parsed JSON value without any warnings
+noJSONWarnings :: a -> WithJSONWarnings a
+noJSONWarnings v = WithJSONWarnings v []
+
+-- | JSON parser that warns about unexpected fields in objects.
+type WarningParser a = WriterT WarningParserMonoid Parser a
+
+-- | Monoid used by 'WarningParser' to track expected fields and warnings.
+data WarningParserMonoid = WarningParserMonoid
+ { wpmExpectedFields :: !(Set Text)
+ , wpmWarnings :: [JSONWarning]
+ } deriving Generic
+instance Semigroup WarningParserMonoid where
+ (<>) = mappenddefault
+instance Monoid WarningParserMonoid where
+ mempty = memptydefault
+ mappend = (<>)
+instance IsString WarningParserMonoid where
+ fromString s = mempty { wpmWarnings = [fromString s] }
+
+-- Parsed JSON value with its warnings
+data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
+ deriving (Eq, Generic, Show)
+instance Functor WithJSONWarnings where
+ fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
+instance Monoid a => Semigroup (WithJSONWarnings a) where
+ (<>) = mappenddefault
+instance Monoid a => Monoid (WithJSONWarnings a) where
+ mempty = memptydefault
+ mappend = (<>)
+
+-- | Warning output from 'WarningParser'.
+data JSONWarning = JSONUnrecognizedFields String [Text]
+ | JSONGeneralWarning !Text
+ deriving Eq
+instance Show JSONWarning where
+ show = T.unpack . utf8BuilderToText . display
+instance Display JSONWarning where
+ display (JSONUnrecognizedFields obj [field]) =
+ "Unrecognized field in " <> fromString obj <> ": " <> display field
+ display (JSONUnrecognizedFields obj fields) =
+ "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields)
+ display (JSONGeneralWarning t) = display t
+
+instance IsString JSONWarning where
+ fromString = JSONGeneralWarning . T.pack
+
+instance FromJSON (WithJSONWarnings StylesUpdate) where
+ parseJSON v = noJSONWarnings <$> parseJSON v
diff --git a/src/Pantry/Internal/Companion.hs b/src/Pantry/Internal/Companion.hs
new file mode 100644
index 0000000..e1e0ea8
--- /dev/null
+++ b/src/Pantry/Internal/Companion.hs
@@ -0,0 +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)
diff --git a/src/Pantry/Internal/Stackage.hs b/src/Pantry/Internal/Stackage.hs
new file mode 100644
index 0000000..1a76a2c
--- /dev/null
+++ b/src/Pantry/Internal/Stackage.hs
@@ -0,0 +1,51 @@
+-- | 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(..)
+ , TreeEntry(..)
+ , TreeEntryId
+ , TreeId
+ , Unique(..)
+ , Version
+ , VersionId
+ , getBlobKey
+ , getPackageNameById
+ , getPackageNameId
+ , getTreeForKey
+ , getVersionId
+ , loadBlobById
+ , migrateAll
+ , treeCabal
+ , Key(unBlobKey)
+ )
+import Pantry.Types as X
+ ( ModuleNameP(..)
+ , PackageNameP(..)
+ , PantryConfig(..)
+ , SafeFilePath
+ , Storage(..)
+ , VersionP(..)
+ , mkSafeFilePath
+ , packageNameString
+ , packageTreeKey
+ , parsePackageName
+ , parseVersion
+ , parseVersionThrowing
+ , unSafeFilePath
+ , versionString
+ )
diff --git a/src/Pantry/Internal/StaticBytes.hs b/src/Pantry/Internal/StaticBytes.hs
new file mode 100644
index 0000000..4c37a92
--- /dev/null
+++ b/src/Pantry/Internal/StaticBytes.hs
@@ -0,0 +1,237 @@
+{-# 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
diff --git a/src/Pantry/Repo.hs b/src/Pantry/Repo.hs
new file mode 100644
index 0000000..bc43728
--- /dev/null
+++ b/src/Pantry/Repo.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+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 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)
+
+fetchReposRaw
+ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => [(Repo, RawPackageMetadata)]
+ -> RIO env ()
+fetchReposRaw pairs = for_ pairs $ uncurry getRepo
+
+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 =
+ withCache $ getRepo' repo pm
+ where
+ withCache
+ :: RIO env Package
+ -> RIO env Package
+ withCache inner = do
+ mtid <- withStorage (loadRepoCache repo (repoSubdir 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 rpm = do
+ withRepoArchive 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 repo
+ }
+ 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)
+ => Repo
+ -> (FilePath -> RIO env a)
+ -> RIO env a
+withRepoArchive repo action =
+ withSystemTempDirectory "with-repo-archive" $ \tmpdir -> do
+ let tarball = tmpdir </> "foo.tar"
+ createRepoArchive repo 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"
+
+-- | 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)
+ => Repo
+ -> FilePath -- ^ Output tar archive filename
+ -> RIO env ()
+createRepoArchive repo tarball = do
+ withRepo repo $ case repoType repo of
+ RepoGit -> do
+ runGitCommand ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"]
+ -- also include submodules files: use `git submodule foreach` to
+ -- execute `git archive` in each submodule and to append the
+ -- generated archive to the main one with `tar -A`
+ runGitCommand
+ [ "submodule", "foreach", "--recursive"
+ , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD"
+ <> " && if [ -f bar.tar ]; then tar --force-local -Af " <> tarball <> " bar.tar ; fi"
+ ]
+ 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)
+ => Repo
+ -> RIO env a
+ -> RIO env a
+withRepo repo@(Repo url commit repoType' _subdir) action =
+ withSystemTempDirectory "with-repo" $
+ \tmpdir -> withWorkingDir tmpdir $ do
+ let suffix = "cloned"
+ dir = tmpdir </> suffix
+
+ let (runCommand, resetArgs, submoduleArgs) =
+ case repoType' of
+ RepoGit ->
+ ( runGitCommand
+ , ["reset", "--hard", T.unpack commit]
+ , Just ["submodule", "update", "--init", "--recursive"]
+ )
+ RepoHg ->
+ ( runHgCommand
+ , ["update", "-C", T.unpack commit]
+ , Nothing
+ )
+
+ logInfo $ "Cloning " <> display commit <> " from " <> display url
+ runCommand ("clone" : [T.unpack url, suffix])
+ -- 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
+ created <- doesDirectoryExist dir
+ unless created $ throwIO $ FailedToCloneRepo repo
+
+ withWorkingDir dir $ do
+ runCommand resetArgs
+ traverse_ runCommand submoduleArgs
+ -- On Windows 10, an upstream issue with the `git submodule` 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
+ action
diff --git a/src/Pantry/SHA256.hs b/src/Pantry/SHA256.hs
new file mode 100644
index 0000000..021af5f
--- /dev/null
+++ b/src/Pantry/SHA256.hs
@@ -0,0 +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
diff --git a/src/Pantry/SQLite.hs b/src/Pantry/SQLite.hs
new file mode 100644
index 0000000..91da13a
--- /dev/null
+++ b/src/Pantry/SQLite.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+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;"]
+
+ -- When doing a migration, we want to disable foreign key
+ -- checking, since the order in which tables are created by
+ -- the migration scripts may not respect foreign keys. The
+ -- rest of the time: enforce those foreign keys.
+ $ set fkEnabled (not isMigration)
+
+ $ mkSqliteConnectionInfo (fromString $ toFilePath fp)
+
+-- | Ensure that only one process is trying to write to the database
+-- at a time. See
+-- https://github.com/commercialhaskell/stack/issues/4471 and comments
+-- above.
+withWriteLock
+ :: HasLogFunc env
+ => Utf8Builder -- ^ database description, for lock messages
+ -> Path Abs File -- ^ SQLite database file
+ -> RIO env a
+ -> RIO env a
+withWriteLock desc dbFile inner = do
+ let lockFile = toFilePath dbFile ++ ".pantry-write-lock"
+ withRunInIO $ \run -> do
+ mres <- withTryFileLock lockFile Exclusive $ const $ run inner
+ case mres of
+ Just res -> pure res
+ Nothing -> do
+ let complainer :: Companion IO
+ complainer delay = run $ do
+ -- Wait five seconds before giving the first message to
+ -- avoid spamming the user for uninteresting file locks
+ delay $ 5 * 1000 * 1000 -- 5 seconds
+ logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..."
+
+ -- Now loop printing a message every 1 minute
+ forever $ do
+ delay (60 * 1000 * 1000) -- 1 minute
+ `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock")
+ logWarn ("Still waiting on the " <> desc <> " database write lock...")
+ withCompanion complainer $ \stopComplaining ->
+ withFileLock lockFile Exclusive $ const $ do
+ stopComplaining
+ run inner
diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs
new file mode 100644
index 0000000..eeecb8d
--- /dev/null
+++ b/src/Pantry/Storage.hs
@@ -0,0 +1,1101 @@
+{-# 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 #-}
+module Pantry.Storage
+ ( SqlBackend
+ , initStorage
+ , withStorage
+ , migrateAll
+ , storeBlob
+ , loadBlob
+ , loadBlobById
+ , loadBlobBySHA
+ , 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
+ , PackageNameId
+ , PackageName
+ , VersionId
+ , ModuleNameId
+ , Version
+ , Unique(..)
+ , EntityField(..)
+ -- avoid warnings
+ , BlobId
+ , Key(unBlobKey)
+ , HackageCabalId
+ , HackageCabal(..)
+ , HackageTarballId
+ , CacheUpdateId
+ , FilePathId
+ , Tree(..)
+ , TreeId
+ , TreeEntry(..)
+ , TreeEntryId
+ , ArchiveCacheId
+ , RepoCacheId
+ , PreferredVersionsId
+ , UrlBlobId
+ , SnapshotCacheId
+ , PackageExposedModuleId
+ ) 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 ()
+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 (..))
+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 =
+ flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage)
+
+-- | 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 <- 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
+
+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)
+
+
+storeTree
+ :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+ => P.RawPackageLocationImmutable -- ^ for exceptions
+ -> P.PackageIdentifier
+ -> P.Tree
+ -> P.BuildFile
+ -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey)
+storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = do
+ (bid, blobKey) <- storeBlob $ P.renderTree 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) -> do
+ sfpid <- getFilePathId sfp
+ mbid <- getBlobId blobKey'
+ bid' <-
+ case mbid of
+ Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey'
+ Just bid' -> pure bid'
+ 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
+ -> Text -- ^ subdir
+ -> ReaderT SqlBackend (RIO env) (Maybe TreeId)
+loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst
+ [ RepoCacheUrl ==. repoUrl repo
+ , RepoCacheType ==. repoType repo
+ , RepoCacheCommit ==. repoCommit repo
+ , RepoCacheSubdir ==. subdir
+ ]
+ [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
diff --git a/src/Pantry/Tree.hs b/src/Pantry/Tree.hs
new file mode 100644
index 0000000..63f2e25
--- /dev/null
+++ b/src/Pantry/Tree.hs
@@ -0,0 +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.Common (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 errs warnings
+ Right gpkg -> return (warnings, gpkg)
+ where
+ (warnings, eres) = runParseResult $ parseGenericPackageDescription bs
diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs
new file mode 100644
index 0000000..4a66195
--- /dev/null
+++ b/src/Pantry/Types.hs
@@ -0,0 +1,2274 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiWayIf #-}
+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
+ , SHA256
+ , Unresolved
+ , resolvePaths
+ , Package (..)
+ , PackageCabal (..)
+ , PHpack (..)
+ -- , PackageTarball (..)
+ , RawPackageLocation (..)
+ , PackageLocation (..)
+ , toRawPL
+ , RawPackageLocationImmutable (..)
+ , PackageLocationImmutable (..)
+ , toRawPLI
+ , RawArchive (..)
+ , Archive (..)
+ , toRawArchive
+ , Repo (..)
+ , 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
+ , ltsSnapshotLocation
+ , nightlySnapshotLocation
+ , RawSnapshotLocation (..)
+ , SnapshotLocation (..)
+ , toRawSL
+ , parseHackageText
+ , parseRawSnapshotLocation
+ , RawSnapshotLayer (..)
+ , SnapshotLayer (..)
+ , toRawSnapshotLayer
+ , RawSnapshot (..)
+ , Snapshot (..)
+ , RawSnapshotPackage (..)
+ , SnapshotPackage (..)
+ , parseWantedCompiler
+ , RawPackageMetadata (..)
+ , PackageMetadata (..)
+ , toRawPM
+ , cabalFileName
+ , SnapshotCacheHash (..)
+ , getGlobalHintsFile
+ , bsToBlobKey
+ ) 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.Char (isSpace)
+import RIO.List (intersperse)
+import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime)
+import qualified RIO.Map as Map
+import qualified RIO.HashMap as HM
+import qualified Data.Map.Strict as Map (mapKeysMonotonic)
+import qualified RIO.Set as Set
+import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..))
+import Data.Aeson.Types (ToJSONKey (..) ,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.ReadP as Parse
+import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)
+import Distribution.Parsec.Common (PError (..), PWarning (..), showPos)
+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.Text
+import qualified Hpack.Config as Hpack
+import Distribution.ModuleName (ModuleName)
+import Distribution.Types.Version (Version, mkVersion)
+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 Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
+
+-- | 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)
+
+data PHpack = PHpack
+ {
+ phOriginal :: !TreeEntry, -- ^ Original hpack file
+ phGenerated :: !TreeEntry, -- ^ Generated Cabal file
+ phVersion :: !Version -- ^ Version of Hpack used
+ } deriving (Show, Eq)
+
+data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file
+ | PCHpack !PHpack
+ deriving (Show, Eq)
+
+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
+ }
+
+-- | 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
+ _ -> fail $ "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)
+
+
+-- 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" ..!= False
+ 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 -> [(Text, 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
+ (T.pack . 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 = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do
+ let (identT, cfiT) = T.break (== '@') t
+ PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT
+ (csha, csize) <-
+ 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 -> Nothing
+ Just sizeT' ->
+ case decimal sizeT' of
+ Right (size', "") -> Just $ (sha, FileSize size')
+ _ -> Nothing
+ pure msize
+ _ -> Nothing
+ pure $ (PackageIdentifier name version, BlobKey csha csize)
+
+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)
+ !BlobKey -- cabal file found
+ !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 !Repo
+ | 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
+
+ deriving Typeable
+instance Exception PantryException where
+instance Show PantryException where
+ show = T.unpack . utf8BuilderToText . display
+instance Display PantryException where
+ 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 foundCabal foundIdent) =
+ "Mismatched package metadata for " <> display loc <>
+ "\nFound: " <> fromString (packageIdentifierString foundIdent) <> " with cabal file " <>
+ display foundCabal <>
+ (case mtreeKey of
+ Nothing -> mempty
+ Just treeKey -> " and 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."
+
+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 ", "
+
+-- You'd really think there'd be a better way to do this in Cabal.
+cabalSpecLatestVersion :: Version
+cabalSpecLatestVersion =
+ case cabalSpecLatest of
+ CabalSpecOld -> error "this cannot happen"
+ CabalSpecV1_22 -> error "this cannot happen"
+ CabalSpecV1_24 -> error "this cannot happen"
+ CabalSpecV2_0 -> error "this cannot happen"
+ CabalSpecV2_2 -> error "this cannot happen"
+ CabalSpecV2_4 -> mkVersion [2, 4]
+
+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)
+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)
+
+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)
+
+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 <> ":"
+
+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 defaul value
+--
+-- @since 0.1.0.0
+parsePackageIdentifier :: String -> Maybe PackageIdentifier
+parsePackageIdentifier str =
+ case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of
+ [] -> Nothing
+ (p:_) -> Just p
+ where
+ parser = do
+ n <- Distribution.Text.parse
+ -- version is a required component of a package identifier for Stack
+ v <- Parse.char '-' >> Distribution.Text.parse
+ return (PackageIdentifier n v)
+
+-- | 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
+ , rpmCabal :: !(Maybe BlobKey)
+ -- ^ Blob key containing the cabal file
+ --
+ -- @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
+ , (\cabal -> "cabal file == " <> display cabal) <$> rpmCabal 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
+ , pmCabal :: !BlobKey
+ -- ^ Blob key containing the cabal file
+ --
+ -- @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)
+ , "cabal file == " <> display (pmCabal pm)
+ ]
+
+parsePackageMetadata :: Object -> WarningParser PackageMetadata
+parsePackageMetadata o = do
+ pmCabal :: 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) (Just $ pmCabal 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") >>= validateUrl) <|>
+ ((o ..: "filepath") >>= validateFilePath) <|>
+ ((o ..: "archive") >>= parseArchiveLocationText) <|>
+ ((o ..: "location") >>= parseArchiveLocationText)
+
+-- Forgive me my father, for I have sinned (bad fail, bad!)
+parseArchiveLocationText :: (Monad m, Alternative m) => Text -> m (Unresolved ArchiveLocation)
+parseArchiveLocationText t = validateUrl t <|> validateFilePath t
+
+validateUrl :: Monad m => Text -> m (Unresolved ArchiveLocation)
+validateUrl t =
+ case parseRequest $ T.unpack t of
+ Left _ -> fail $ "Could not parse URL: " ++ T.unpack t
+ Right _ -> pure $ pure $ ALUrl t
+
+validateFilePath :: Monad m => Text -> m (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 fail $ "Does not have an archive file extension: " ++ T.unpack 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 -> [(Text, Value)]
+rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat
+ [ maybe [] (\name -> ["name" .= CabalString name]) mname
+ , maybe [] (\version -> ["version" .= CabalString version]) mversion
+ , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree
+ , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal
+ ]
+
+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
+ Nothing -> fail $ "Invalid archive location: " ++ T.unpack t
+ Just (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
+ <*> (RawPackageMetadata
+ <$> (fmap unCabalString <$> (o ..:? "name"))
+ <*> (fmap unCabalString <$> (o ..:? "version"))
+ <*> o ..:? "pantry-tree"
+ <*> o ..:? "cabal-file")
+
+ 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 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.Text.Text a => ToJSON (CabalString a) where
+ toJSON = toJSON . Distribution.Text.display . unCabalString
+instance Distribution.Text.Text 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) =
+ fromMaybe (display url) (specialRawSnapshotLocation 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)) <|>
+ parseLts <|>
+ parseNightly <|>
+ parseGithub <|>
+ parseUrl
+ where
+ parseLts = do
+ t1 <- T.stripPrefix "lts-" t0
+ Right (x, t2) <- Just $ decimal t1
+ t3 <- T.stripPrefix "." t2
+ Right (y, "") <- Just $ decimal t3
+ Just $ pure $ ltsSnapshotLocation x y
+ parseNightly = do
+ t1 <- T.stripPrefix "nightly-" t0
+ date <- readMaybe (T.unpack t1)
+ Just $ pure $ nightlySnapshotLocation date
+
+ 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"
+
+-- | Location of an LTS snapshot
+--
+-- @since 0.1.0.0
+ltsSnapshotLocation
+ :: Int -- ^ major version
+ -> Int -- ^ minor version
+ -> RawSnapshotLocation
+ltsSnapshotLocation x y =
+ githubSnapshotLocation defUser defRepo $
+ utf8BuilderToText $
+ "lts/" <> display x <> "/" <> display y <> ".yaml"
+
+-- | Location of a Stackage Nightly snapshot
+--
+-- @since 0.1.0.0
+nightlySnapshotLocation :: Day -> RawSnapshotLocation
+nightlySnapshotLocation date =
+ githubSnapshotLocation defUser defRepo $
+ utf8BuilderToText $
+ "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml"
+ where
+ (year, month, day) = toGregorian date
+
+-- | 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
+ deriving (Show, Eq, Ord, Generic)
+
+instance NFData RawSnapshotLocation
+
+instance Display RawSnapshotLocation where
+ display (RSLCompiler compiler) = display compiler
+ display (RSLUrl url Nothing) = fromMaybe (display url) $ specialRawSnapshotLocation url
+ display (RSLUrl url (Just blob)) =
+ fromMaybe (display url) (specialRawSnapshotLocation url) <>
+ " (" <> display blob <> ")"
+ display (RSLFilePath resolved) = display (resolvedRelative resolved)
+
+-- | For nicer display purposes: present a 'RawSnapshotLocation' as a
+-- short form like lts-13.13 if possible.
+specialRawSnapshotLocation :: Text -> Maybe Utf8Builder
+specialRawSnapshotLocation url = do
+ t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" url
+ parseLTS t1 <|> parseNightly t1
+ where
+ popInt :: Text -> Maybe (Int, Text)
+ popInt t0 =
+ -- Would be nice if this function did overflow checking for us
+ case decimal t0 of
+ Left _ -> Nothing
+ Right (x, rest) -> (, rest) <$> do
+ if (x :: Integer) > fromIntegral (maxBound :: Int)
+ then Nothing
+ else Just (fromIntegral x)
+
+ parseLTS t1 = do
+ t2 <- T.stripPrefix "lts/" t1
+ (major, t3) <- popInt t2
+ (minor, ".yaml") <- T.stripPrefix "/" t3 >>= popInt
+ Just $ "lts-" <> display major <> "." <> display minor
+ parseNightly t1 = do
+ t2 <- T.stripPrefix "nightly/" t1
+ (year, t3) <- popInt t2
+ (month, t4) <- T.stripPrefix "/" t3 >>= popInt
+ (day, ".yaml") <- T.stripPrefix "/" t4 >>= popInt
+ date <- fromGregorianValid (fromIntegral year) month day
+ Just $ "nightly-" <> displayShow date
+
+instance ToJSON RawSnapshotLocation where
+ toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]
+ toJSON (RSLUrl url Nothing)
+ | Just x <- specialRawSnapshotLocation url = String $ utf8BuilderToText x
+ toJSON (RSLUrl url mblob) = object
+ $ "url" .= url
+ : maybe [] blobKeyPairs mblob
+ toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved]
+
+-- | 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)))
diff --git a/src/unix/System/IsWindows.hs b/src/unix/System/IsWindows.hs
new file mode 100644
index 0000000..b8ef69e
--- /dev/null
+++ b/src/unix/System/IsWindows.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module System.IsWindows
+ ( osIsWindows
+ ) where
+
+import RIO (Bool (..))
+
+-- | False if not using Windows OS.
+osIsWindows :: Bool
+osIsWindows = False
diff --git a/src/windows/System/IsWindows.hs b/src/windows/System/IsWindows.hs
new file mode 100644
index 0000000..d0b3d9d
--- /dev/null
+++ b/src/windows/System/IsWindows.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module System.IsWindows
+ ( osIsWindows
+ ) where
+
+import RIO (Bool (..))
+
+-- | True if using Windows OS.
+osIsWindows :: Bool
+osIsWindows = True
diff --git a/test/Pantry/ArchiveSpec.hs b/test/Pantry/ArchiveSpec.hs
new file mode 100644
index 0000000..86fd49e
--- /dev/null
+++ b/test/Pantry/ArchiveSpec.hs
@@ -0,0 +1,104 @@
+{-# 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
+ , rpmCabal = Nothing
+ }
+
+parsePackageIdentifier' :: String -> PackageIdentifier
+parsePackageIdentifier' = fromJust . parsePackageIdentifier
+
+urlToStackCommit :: Text -> TestLocation
+urlToStackCommit commit = TLUrl $ T.concat
+ [ "https://github.com/commercialhaskell/stack/archive/"
+ , commit
+ , ".tar.gz"
+ ]
+
+treeWithoutCabalFile :: Selector PantryException
+treeWithoutCabalFile (TreeWithoutCabalFile _) = True
+treeWithoutCabalFile _ = False
+
+spec :: Spec
+spec = do
+ it "finds cabal file from tarball" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz"
+ , testSubdir = ""
+ }
+ ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3"
+ it "finds cabal file from tarball with subdir '.'" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz"
+ , testSubdir = "."
+ }
+ ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3"
+ it "finds cabal file from tarball with a package.yaml" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz"
+ , testSubdir = ""
+ }
+ ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3"
+ it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz"
+ , testSubdir = "."
+ }
+ ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3"
+ it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc"
+ , testSubdir = "subs/pantry/"
+ }
+ ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0"
+ it "matches whole directory name" $
+ getRawPackageLocationIdent' TestArchive
+ { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc"
+ , testSubdir = "subs/pant"
+ }
+ `shouldThrow` treeWithoutCabalFile
+ it "follows symlinks to directories" $ do
+ ident <- getRawPackageLocationIdent' TestArchive
+ { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz"
+ , testSubdir = "symlink"
+ }
+ ident `shouldBe` parsePackageIdentifier' "foo-1.2.3"
diff --git a/test/Pantry/BuildPlanSpec.hs b/test/Pantry/BuildPlanSpec.hs
new file mode 100644
index 0000000..41fc328
--- /dev/null
+++ b/test/Pantry/BuildPlanSpec.hs
@@ -0,0 +1,121 @@
+{-# 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
+ , rpmCabal = 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
+ , rpmCabal = Nothing
+ }
+ actual <- decode'' contents
+ actual `shouldBe` pure expected
+
+ it "does not parse GitHub repo with no slash" $ do
+ let contents :: ByteString
+ contents =
+ S8.pack
+ (unlines
+ [ "github: oink"
+ , "commit: abc123"
+ ])
+ void (decode' contents) `shouldBe` Nothing
+
+ it "does not parse GitHub repo with leading slash" $ do
+ let contents :: ByteString
+ contents =
+ S8.pack
+ (unlines
+ [ "github: /oink"
+ , "commit: abc123"
+ ])
+ void (decode' contents) `shouldBe` Nothing
+
+ it "does not parse GitHub repo with trailing slash" $ do
+ let contents :: ByteString
+ contents =
+ S8.pack
+ (unlines
+ [ "github: oink/"
+ , "commit: abc123"
+ ])
+ void (decode' contents) `shouldBe` Nothing
+
+ it "does not parse GitHub repo with more than one slash" $ do
+ let contents :: ByteString
+ contents =
+ S8.pack
+ (unlines
+ [ "github: oink/town/here"
+ , "commit: abc123"
+ ])
+ void (decode' contents) `shouldBe` Nothing
diff --git a/test/Pantry/CabalSpec.hs b/test/Pantry/CabalSpec.hs
new file mode 100644
index 0000000..bcbbc71
--- /dev/null
+++ b/test/Pantry/CabalSpec.hs
@@ -0,0 +1,112 @@
+{-# 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 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 cabal ident ->
+ rpli == rpli' &&
+ rpm == RawPackageMetadata
+ { rpmName = Just name
+ , rpmVersion = Just version3
+ , rpmTreeKey = Nothing
+ , rpmCabal = Just $ BlobKey sha size
+ } &&
+ cabal == BlobKey sha size &&
+ ident == PackageIdentifier name version2
+ _ -> False
+
+ test "tarball with wrong ident" $ do
+ archiveHash' <- either throwIO pure
+ $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a"
+ sha <- either throwIO pure
+ $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69"
+ 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
+ , rpmCabal = Just $ BlobKey sha (FileSize 597)
+ , rpmTreeKey = Nothing
+ }
+ go = loadCabalFileRawImmutable rpli
+ acmeMissiles = mkPackageName "acme-missiles"
+ version2 = mkVersion [0, 2]
+ go `shouldThrow'` \e ->
+ case e of
+ MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident ->
+ rpli == rpli' &&
+ rpm == rpm' &&
+ cabal == BlobKey
+ (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50")
+ (FileSize 3038) &&
+ ident == PackageIdentifier
+ (mkPackageName "yesod-auth")
+ (mkVersion [1, 6, 4, 1])
+ _ -> False
+
+ test "tarball with wrong cabal file" $ do
+ sha <- either throwIO pure
+ $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69"
+ 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 version
+ , rpmCabal = Just $ BlobKey sha (FileSize 597)
+ , rpmTreeKey = Nothing
+ }
+ go = loadCabalFileRawImmutable rpli
+ yesodAuth = mkPackageName "yesod-auth"
+ version = mkVersion [1, 6, 4, 1]
+ go `shouldThrow'` \e ->
+ case e of
+ MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident ->
+ rpli == rpli' &&
+ rpm == rpm' &&
+ cabal == BlobKey
+ (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50")
+ (FileSize 3038) &&
+ ident == PackageIdentifier yesodAuth version
+ _ -> False
diff --git a/test/Pantry/FileSpec.hs b/test/Pantry/FileSpec.hs
new file mode 100644
index 0000000..22df566
--- /dev/null
+++ b/test/Pantry/FileSpec.hs
@@ -0,0 +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
diff --git a/test/Pantry/GlobalHintsSpec.hs b/test/Pantry/GlobalHintsSpec.hs
new file mode 100644
index 0000000..8d01bf0
--- /dev/null
+++ b/test/Pantry/GlobalHintsSpec.hs
@@ -0,0 +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
diff --git a/test/Pantry/HackageSpec.hs b/test/Pantry/HackageSpec.hs
new file mode 100644
index 0000000..6cc6c1a
--- /dev/null
+++ b/test/Pantry/HackageSpec.hs
@@ -0,0 +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`)
diff --git a/test/Pantry/Internal/StaticBytesSpec.hs b/test/Pantry/Internal/StaticBytesSpec.hs
new file mode 100644
index 0000000..09e3c01
--- /dev/null
+++ b/test/Pantry/Internal/StaticBytesSpec.hs
@@ -0,0 +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
diff --git a/test/Pantry/InternalSpec.hs b/test/Pantry/InternalSpec.hs
new file mode 100644
index 0000000..41ab41e
--- /dev/null
+++ b/test/Pantry/InternalSpec.hs
@@ -0,0 +1,73 @@
+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"
+ "../bob/fred" ! Nothing
+ "../bob/fred/" ! Nothing
+ "./bob/fred/" ! Just "bob/fred"
+ "./bob/fred" ! Just "bob/fred"
+ "./" ! Nothing
+ "./." ! Nothing
+ "/./" ! Nothing
+ "/" ! Nothing
+ "bob/fred/." ! Nothing
+ "//home" ! Nothing
+ "foobarbaz\\bin" ! Just "foobarbaz\\bin"
+
+ describe "makeTarRelative" $ do
+ let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec
+ test base rel expected =
+ it (show (base, rel)) $
+ either (const Nothing) Just (makeTarRelative base rel)
+ `shouldBe` expected
+
+ test "foo/bar" "baz" $ Just "foo/baz"
+ test "foo" "bar" $ Just "bar"
+ test "foo" "/bar" Nothing
+ test "foo/" "bar" Nothing
+
+ -- MSS 2018-08-23: Arguable whether this should be Nothing
+ -- instead, since we don't want any absolute paths. However,
+ -- that's really a concern for normalizeParents. Point being: if
+ -- you refactor in the future, and this turns into Nothing, that's
+ -- fine.
+ test "/foo" "bar" $ Just "/bar"
+
+ describe "Parse HPack version" $ do
+ {-
+ let isVersion :: Version -> Bool
+ isVersion _ = True
+ -}
+
+ it "Shipped hpack version" $ example $ do
+ _version <- runPantryApp hpackVersion
+ -- version `shouldSatisfy` isVersion
+ pure ()
+
+ -- it "External hpack version" $ do
+ -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion
+ -- version `shouldSatisfy` isVersion
diff --git a/test/Pantry/TreeSpec.hs b/test/Pantry/TreeSpec.hs
new file mode 100644
index 0000000..459be2c
--- /dev/null
+++ b/test/Pantry/TreeSpec.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Pantry.TreeSpec (spec) where
+
+import Test.Hspec
+import RIO
+import Pantry
+
+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
+ , rpmCabal = 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
+ it "archive and Hg repo match" $ asIO $ runPantryAppClean $ do
+ pair1 <- loadPackageRaw tarPL
+ pair2 <- loadPackageRaw hgPL
+ liftIO $ pair2 `shouldBe` pair1
diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs
new file mode 100644
index 0000000..59fb1f4
--- /dev/null
+++ b/test/Pantry/TypesSpec.hs
@@ -0,0 +1,216 @@
+{-# 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:
+ 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|
+cabal-file:
+ size: 1863
+ sha256: 5ebffc39e75ea1016adcc8426dc31d2040d2cc8a5f4bbce228592ef35e233da2
+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` ltsSnapshotLocation 2 10
+
+ it "parses snapshot using 'snapshot'" $ do
+ RawSnapshotLayer{..} <- parseSl $
+ "name: 'test'\n" ++
+ "snapshot: lts-2.10\n"
+ rslParent `shouldBe` ltsSnapshotLocation 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 an LTS gives a nice name" $ property $ do
+ (major, minor) <- forAll $ (,)
+ <$> Gen.integral (Range.linear 1 10000)
+ <*> Gen.integral (Range.linear 1 10000)
+ liftIO $
+ Yaml.toJSON (ltsSnapshotLocation major minor) `shouldBe`
+ Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor])
+
+ hh "rendering a nightly gives a nice name" $ property $ do
+ days <- forAll $ Gen.integral $ Range.linear 1 10000000
+ let day = ModifiedJulianDay days
+ liftIO $
+ Yaml.toJSON (nightlySnapshotLocation 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"
+ }
+ cabalSha =
+ SHA256.fromHexBytes
+ "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410"
+ pantrySha =
+ SHA256.fromHexBytes
+ "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2"
+ (csha, psha) <- case (cabalSha, pantrySha) of
+ (Right csha, Right psha) -> pure (csha, psha)
+ _ -> fail "Failed decoding sha256"
+ let pkgValue =
+ PackageMetadata
+ { pmIdent =
+ PackageIdentifier
+ (mkPackageName "wai")
+ (mkVersion [3, 2, 1, 2])
+ , pmTreeKey = TreeKey (BlobKey psha (FileSize 714))
+ , pmCabal = BlobKey csha (FileSize 1765)
+ }
+ 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)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}