packages feed

pantry (empty) → 0.1.0.0

raw patch · 35 files changed

+9001/−0 lines, 35 filesdep +Cabaldep +QuickCheckdep +aesonbinary-added

Dependencies added: Cabal, QuickCheck, aeson, ansi-terminal, array, base, 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

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for pantry++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ attic/package-0.1.2.3.tar.gz view

binary file changed (absent → 205 bytes)

+ pantry.cabal view
@@ -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
+ src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs view
@@ -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
+ src/Pantry.hs view
@@ -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
+ src/Pantry/Archive.hs view
@@ -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
+ src/Pantry/HPack.hs view
@@ -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_
+ src/Pantry/HTTP.hs view
@@ -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'
+ src/Pantry/Hackage.hs view
@@ -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)+            }
+ src/Pantry/Internal.hs view
@@ -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
+ src/Pantry/Internal/AesonExtended.hs view
@@ -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
+ src/Pantry/Internal/Companion.hs view
@@ -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)
+ src/Pantry/Internal/Stackage.hs view
@@ -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+  )
+ src/Pantry/Internal/StaticBytes.hs view
@@ -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
+ src/Pantry/Repo.hs view
@@ -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
+ src/Pantry/SHA256.hs view
@@ -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
+ src/Pantry/SQLite.hs view
@@ -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
+ src/Pantry/Storage.hs view
@@ -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
+ src/Pantry/Tree.hs view
@@ -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
+ src/Pantry/Types.hs view
@@ -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)))
+ src/unix/System/IsWindows.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}+module System.IsWindows+  ( osIsWindows+  ) where++import RIO (Bool (..))++-- | False if not using Windows OS.+osIsWindows :: Bool+osIsWindows = False
+ src/windows/System/IsWindows.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}+module System.IsWindows+  ( osIsWindows+  ) where++import RIO (Bool (..))++-- | True if using Windows OS.+osIsWindows :: Bool+osIsWindows = True
+ test/Pantry/ArchiveSpec.hs view
@@ -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"
+ test/Pantry/BuildPlanSpec.hs view
@@ -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
+ test/Pantry/CabalSpec.hs view
@@ -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
+ test/Pantry/FileSpec.hs view
@@ -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
+ test/Pantry/GlobalHintsSpec.hs view
@@ -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
+ test/Pantry/HackageSpec.hs view
@@ -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`)
+ test/Pantry/Internal/StaticBytesSpec.hs view
@@ -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
+ test/Pantry/InternalSpec.hs view
@@ -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
+ test/Pantry/TreeSpec.hs view
@@ -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
+ test/Pantry/TypesSpec.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}