diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for pantry + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2015-2019, Stack contributors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Stack nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL STACK CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,218 @@ +# pantry + +TODO: Add Travis and AppVeyor badges + +Content addressable Haskell package management, providing for secure, +reproducible acquisition of Haskell package contents and metadata. + +## What is Pantry + +* A Haskell library, command line executable, storage specification, and + network protocol +* Intended for content-addressable storage of Haskell packages +* Allows non-centralized package storage +* Primarily for use by Stackage and Stack, hopefully other tools as well + +## Goals + +* Efficient, distributed package storage for Haskell +* Superset of existing storage mechanisms +* Security via content addressable storage +* Allow more Stackage-style snapshots to exist +* Allow authors to bypass Hackage for uploads +* Allow Stackage to create forks of packages on Hackage + +__TODO__ + +Content below needs to be updated. + +* Support for hpack in PackageLocationImmutable? + +## Package definition + +Pantry defines the following concepts: + +* __Blob__: a raw byte sequence, identified by its key (SHA256 of the + contents) +* __Tree entry__: contents of a single file (identified by blob key) + and whether or not it is executable. + * NOTE: existing package formats like tarballs support more + sophisticated options. We explicitly do not support those. If + such functionality is needed, fallback to those mechanism is + required. +* __Tree__: mapping from relative path to a tree entry. Some basic + sanity rules apply to the paths: no `.` or `..` directory + components, no newlines in filepaths, does not begin with `/`, no + `\\` (we normalize to POSIX-style paths). A tree is identified by a + tree key (SHA256 of the tree's serialized format). +* __Package__: a tree key for the package contents, package name, + version number, and cabal file blob key. Requirements: there must be + a single file with a `.cabal` file extension at the root of the + tree, and it must match the cabal file blob key. The cabal file must + be located at `pkgname.cabal`. Each tree can be in at most one + package, and therefore tree keys work as package keys too. + +Note that with the above, a tree key is all the information necessary +to uniquely identify a package. However, including additional +information (package name, version, cabal key) in config files may be +useful for optimizations or user friendliness. If such extra +information is ever included, it must be validated to concur with the +package contents itself. + +### Package location + +Packages will optionally be sourced from some location: + +* __Hackage__ requires the package name, version number, and revision + number. Each revision of a package will end up with a different tree + key. +* __Archive__ takes a URL pointing to a tarball (gzipped or not) or a + ZIP file. An implicit assumption is that archives remain immutable + over time. Use tree keys to verify this assumption. (Same applies to + Hackage for that matter.) +* __Repository__ takes a repo type (Git or Mercurial), URL, and + commit. Assuming the veracity of the cryptographic hashes on the + repos, this should guarantee a unique set of files. + +In order to deal with _megarepos_ (repos and archives containing more +than one package), there is also a subdirectory for the archive and +repository cases. An empty subdir `""` would be the case for a +standard repo/archive. + +In order to meet the rules of a package listed above, the following +logic is applied to all three types above: + +* Find all of the files in the raw location, and represent as `Map + FilePath TreeEntry` (or equivalent). +* Remove a wrapper directory. If _all_ filepaths in that `Map` are + contained within the same directory, strip it from all of the + paths. For example, if the paths are `foo/bar` and `foo/baz`, the + paths will be reduced to `bar` and `baz`. +* After this wrapper is removed, then subdirectory logic is applied, + essentially applying `stripPrefix` to the filepaths. If the subdir + is `yesod-bin` and files exist called `yesod-core/yesod-core.cabal` + and `yesod-bin/yesod-bin.cabal`, the only file remaining after + subdir stripping would be `yesod-bin.cabal`. Note that trailing + slashes must be handled appropriately, and that an empty subdir + string results in this step being a noop. + +The result of all of this is that, given one of the three package +locations above, we can receive a tree key which will provide an +installable package. That tree key will remain immutable. + +### How tooling refers to packages + +We'll get to the caching mechanism for Pantry below. However, the +recommended approach for tooling is to support some kind of composite +of the Pantry keys, parsed info, and raw package location. This allows +for more efficient lookups when available, with a fallback when +mirrors don't have the needed information. + +An example: + +```yaml +extra-deps: +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz +``` + +It is also recommended that tooling provide an easy way to generate +such complete information from, e.g., just the URL of the tarball, and +that upon reading information, hashes, package names, and version +numbers are all checked for correctness. + +## Pantry caching + +One simplistic option for Pantry would be that, every time a piece of +data is needed, Pantry downloads the necessary tarball/Git +repo/etc. However, this would in practice be highly wasteful, since +downloading Git repos and archives just to get a single cabal file +(for plan construction purposes) is overkill. Instead, here's the +basic idea for how caching works: + +* All data for Pantry can be stored in a SQL database. Local tools + like Stack will use an SQLite database. Servers will use PostgreSQL. +* We'll define a network protocol (initially just HTTP, maybe + extending to something more efficient if desired) for querying blobs + and trees. +* When a blob or tree is needed, it is first checked for in the local + SQLite cache. If it's not available there, a request to the Pantry + mirrors (configurable) will be made for the data. Since everything + is content addressable, it is safe to use untrusted mirrors. +* If the data is not available in a mirror, and a location is + provided, the location will be downloaded and cached locally. + +We may also allow these Pantry mirrors to provide some kind of query +interface to find out, e.g., the latest version of a package on +Hackage. That's still TBD. + +## Example: resolving a package location + +To work through a full example, the following three stanzas are intended to +have equivalent behavior: + +```yaml +- archive: https://example.com/foobar-1.2.3.4.tar.gz + +- name: foobar + version: 1.2.3.4 + pantry: deadbeef # tree key + cabal-file: 12345678 # blob key + archive: https://example.com/foobar-1.2.3.4.tar.gz + +- pantry: deadbeef + +``` + +The question is: how does the first one (presumably what a user would want to +enter) be resolved into the second and third? Pantry would follow this set of +steps: + +* Download the tarball from the given URL +* Place each file in the tarball into its store as a blob, getting a blob key + for each. The tarball is now represented as `Map FilePath BlobKey` +* Perform the root directory stripping step, removing a shared path +* Since there's no subdirectory: no subdirectory stripping would be performed +* Serialize the `Map FilePath BlobKey` to a binary format and take its hash to + get a tree key +* Store the tree in the store referenced by its tree key. In our example: the + tree key is `deadbeef`. +* Ensure that the tree is a valid package by checking for a single cabal file + at the root. In our example, that's found in `foobar.cabal` with blob key + `12345678`. +* Parse the cabal file and ensure that it is a valid cabal file, and that its + package name is `foobar`. Grab the version number (1.2.3.4). +* We now know that tree key `deadbeef` is a valid package, and can refer to it + by tree key exclusively. However, including the other information allows us + to verify our assumptions, provide user-friendly readable data, and provide a + fallback if the package isn't in the Pantry cache. + +## More advanced content discovery + +There are three more advanced cases to consider: + +* Providing fall-back locations for content, such as out of concern for a + single URL being removed in the future +* Closed corporate setups, where access to the general internet may either be + impossible or undesirable +* Automatic discovery of missing content by hash + +The following extensions are possible to address these cases: + +* Instead of a single package location, provide a list of package locations + with fallback semantics. +* Corporate environments will be encouraged to run a local Pantry mirror, and + configure clients like Stack to speak to these mirrors instead of the default + ones (or in addition to). +* Provide some kind of federation protocol for Pantry where servers can + registry with each other and requests for content can be pinged to each + other. + +Providing override at the client level for Pantry mirror locations is a +__MUST__. Making it easy to run in a corporate environment is a __SHOULD__. +Providing the fallback package locations seems easy enough that we should +include it initially, but falls under a __SHOULD__. The federated protocol +should be added on-demand. diff --git a/attic/package-0.1.2.3.tar.gz b/attic/package-0.1.2.3.tar.gz new file mode 100644 Binary files /dev/null and b/attic/package-0.1.2.3.tar.gz differ diff --git a/pantry.cabal b/pantry.cabal new file mode 100644 --- /dev/null +++ b/pantry.cabal @@ -0,0 +1,222 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 90b9c809b0a38e3b8a7e330f7e0f3bc7a84c3e21412e271ff389c9b37eece3b8 + +name: pantry +version: 0.1.0.0 +synopsis: Content addressable Haskell package management +description: Please see the README on Github at +category: Development +homepage: https://github.com/commercialhaskell/stack#readme +bug-reports: https://github.com/commercialhaskell/stack/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +copyright: 2018-2019 FP Complete +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + attic/package-0.1.2.3.tar.gz + +source-repository head + type: git + location: https://github.com/commercialhaskell/stack + +library + exposed-modules: + Pantry + Pantry.SHA256 + Pantry.Internal + Pantry.Internal.StaticBytes + Pantry.Internal.Stackage + Pantry.Internal.Companion + Pantry.Internal.AesonExtended + other-modules: + Hackage.Security.Client.Repository.HttpLib.HttpClient + Pantry.Archive + Pantry.HTTP + Pantry.HPack + Pantry.Hackage + Pantry.Repo + Pantry.SQLite + Pantry.Storage + Pantry.Tree + Pantry.Types + hs-source-dirs: + src/ + default-extensions: MonadFailDesugaring + ghc-options: -Wall + build-depends: + Cabal + , aeson + , ansi-terminal + , array + , base >=4.10 && <5 + , base-orphans + , base64-bytestring + , bytestring + , conduit + , conduit-extra + , containers + , contravariant + , cryptonite + , cryptonite-conduit + , deepseq + , digest + , directory + , filelock + , filepath + , generic-deriving + , ghc-prim + , hackage-security + , hashable + , hpack + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , integer-gmp + , memory + , mono-traversable + , mtl + , network + , network-uri + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , primitive + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , safe + , syb + , tar-conduit + , template-haskell + , text + , text-metrics + , th-lift + , th-lift-instances + , th-orphans + , th-reify-many + , th-utilities + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + if os(windows) + other-modules: + System.IsWindows + hs-source-dirs: + src/windows/ + else + other-modules: + System.IsWindows + hs-source-dirs: + src/unix/ + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Pantry.ArchiveSpec + Pantry.BuildPlanSpec + Pantry.CabalSpec + Pantry.FileSpec + Pantry.GlobalHintsSpec + Pantry.HackageSpec + Pantry.Internal.StaticBytesSpec + Pantry.InternalSpec + Pantry.TreeSpec + Pantry.TypesSpec + Paths_pantry + hs-source-dirs: + test + default-extensions: MonadFailDesugaring + ghc-options: -Wall + build-depends: + Cabal + , QuickCheck + , aeson + , ansi-terminal + , array + , base >=4.10 && <5 + , base-orphans + , base64-bytestring + , bytestring + , conduit + , conduit-extra + , containers + , contravariant + , cryptonite + , cryptonite-conduit + , deepseq + , digest + , directory + , exceptions + , filelock + , filepath + , generic-deriving + , ghc-prim + , hackage-security + , hashable + , hedgehog + , hpack + , hspec + , http-client + , http-client-tls + , http-conduit + , http-download + , http-types + , integer-gmp + , memory + , mono-traversable + , mtl + , network + , network-uri + , pantry + , path + , path-io + , persistent + , persistent-sqlite + , persistent-template + , primitive + , raw-strings-qq + , resourcet + , rio + , rio-orphans + , rio-prettyprint + , safe + , syb + , tar-conduit + , template-haskell + , text + , text-metrics + , th-lift + , th-lift-instances + , th-orphans + , th-reify-many + , th-utilities + , time + , transformers + , unix-compat + , unliftio + , unordered-containers + , vector + , yaml + , zip-archive + default-language: Haskell2010 diff --git a/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/HttpLib/HttpClient.hs @@ -0,0 +1,146 @@ +-- Explicitly disabling due to external code {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +-- Taken from +-- https://github.com/well-typed/hackage-security/tree/master/hackage-security-http-client +-- to avoid extra dependencies +module Hackage.Security.Client.Repository.HttpLib.HttpClient ( + httpLib + ) where + +import Control.Exception +import Control.Monad (void) +import Data.ByteString (ByteString) +import Network.URI +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.C8 +import qualified Pantry.HTTP as HTTP + +import Hackage.Security.Client hiding (Header) +import Hackage.Security.Client.Repository.HttpLib +import Hackage.Security.Util.Checked +import qualified Hackage.Security.Util.Lens as Lens + +{------------------------------------------------------------------------------- + Top-level API +-------------------------------------------------------------------------------} + +-- | An 'HttpLib' value using the default global manager +httpLib :: HttpLib +httpLib = HttpLib + { httpGet = get + , httpGetRange = getRange + } + +{------------------------------------------------------------------------------- + Individual methods +-------------------------------------------------------------------------------} + +get :: Throws SomeRemoteError + => [HttpRequestHeader] -> URI + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +get reqHeaders uri callback = wrapCustomEx $ do + -- TODO: setUri fails under certain circumstances; in particular, when + -- the URI contains URL auth. Not sure if this is a concern. + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + callback (getResponseHeaders response) br + +getRange :: Throws SomeRemoteError + => [HttpRequestHeader] -> URI -> (Int, Int) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) + -> IO a +getRange reqHeaders uri (from, to) callback = wrapCustomEx $ do + request' <- HTTP.setUri HTTP.defaultRequest uri + let request = setRange from to + $ setRequestHeaders reqHeaders request' + checkHttpException $ HTTP.withResponse request $ \response -> do + let br = wrapCustomEx $ HTTP.getResponseBody response + case () of + () | HTTP.getResponseStatus response == HTTP.partialContent206 -> + callback HttpStatus206PartialContent (getResponseHeaders response) br + () | HTTP.getResponseStatus response == HTTP.ok200 -> + callback HttpStatus200OK (getResponseHeaders response) br + _otherwise -> + throwChecked $ HTTP.HttpExceptionRequest request + $ HTTP.StatusCodeException (void response) "" + +-- | Wrap custom exceptions +-- +-- NOTE: The only other exception defined in @http-client@ is @TimeoutTriggered@ +-- but it is currently disabled +wrapCustomEx :: (Throws HTTP.HttpException => IO a) + -> (Throws SomeRemoteError => IO a) +wrapCustomEx act = handleChecked (\(ex :: HTTP.HttpException) -> go ex) act + where + go ex = throwChecked (SomeRemoteError ex) + +checkHttpException :: Throws HTTP.HttpException => IO a -> IO a +checkHttpException = handle $ \(ex :: HTTP.HttpException) -> + throwChecked ex + +{------------------------------------------------------------------------------- + http-client auxiliary +-------------------------------------------------------------------------------} + +hAcceptRanges :: HTTP.HeaderName +hAcceptRanges = "Accept-Ranges" + +hAcceptEncoding :: HTTP.HeaderName +hAcceptEncoding = "Accept-Encoding" + +setRange :: Int -> Int + -> HTTP.Request -> HTTP.Request +setRange from to = + HTTP.addRequestHeader HTTP.hRange rangeHeader + where + -- Content-Range header uses inclusive rather than exclusive bounds + -- See + rangeHeader = BS.C8.pack $ "bytes=" ++ show from ++ "-" ++ show (to - 1) + +-- | Set request headers +setRequestHeaders :: [HttpRequestHeader] + -> HTTP.Request -> HTTP.Request +setRequestHeaders opts = + HTTP.setRequestHeaders (trOpt disallowCompressionByDefault opts) + where + trOpt :: [(HTTP.HeaderName, [ByteString])] + -> [HttpRequestHeader] + -> [HTTP.Header] + trOpt acc [] = + concatMap finalizeHeader acc + trOpt acc (HttpRequestMaxAge0:os) = + trOpt (insert HTTP.hCacheControl ["max-age=0"] acc) os + trOpt acc (HttpRequestNoTransform:os) = + trOpt (insert HTTP.hCacheControl ["no-transform"] acc) os + + -- disable content compression (potential security issue) + disallowCompressionByDefault :: [(HTTP.HeaderName, [ByteString])] + disallowCompressionByDefault = [(hAcceptEncoding, [])] + + -- Some headers are comma-separated, others need multiple headers for + -- multiple options. + -- + -- TODO: Right we we just comma-separate all of them. + finalizeHeader :: (HTTP.HeaderName, [ByteString]) + -> [HTTP.Header] + finalizeHeader (name, strs) = [(name, BS.intercalate ", " (reverse strs))] + + insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] + insert x y = Lens.modify (Lens.lookupM x) (++ y) + +-- | Extract the response headers +getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader] +getResponseHeaders response = concat [ + [ HttpResponseAcceptRangesBytes + | (hAcceptRanges, "bytes") `elem` headers + ] + ] + where + headers = HTTP.getResponseHeaders response diff --git a/src/Pantry.hs b/src/Pantry.hs new file mode 100644 --- /dev/null +++ b/src/Pantry.hs @@ -0,0 +1,1602 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Content addressable Haskell package management, providing for +-- secure, reproducible acquisition of Haskell package contents and +-- metadata. +-- +-- @since 0.1.0.0 +module Pantry + ( -- * Running + PantryConfig + , HackageSecurityConfig (..) + , defaultHackageSecurityConfig + , HasPantryConfig (..) + , withPantryConfig + , HpackExecutable (..) + + -- ** Convenience + , PantryApp + , runPantryApp + , runPantryAppClean + , hpackExecutableL + + -- * Types + + -- ** Exceptions + , PantryException (..) + + -- ** Cabal types + , PackageName + , Version + , FlagName + , PackageIdentifier (..) + + -- ** Files + , FileSize (..) + , RelFilePath (..) + , ResolvedPath (..) + , Unresolved + + -- ** Cryptography + , SHA256 + , TreeKey (..) + , BlobKey (..) + + -- ** Packages + , RawPackageMetadata (..) + , PackageMetadata (..) + , Package (..) + + -- ** Hackage + , CabalFileInfo (..) + , Revision (..) + , PackageIdentifierRevision (..) + , UsePreferredVersions (..) + + -- ** Archives + , RawArchive (..) + , Archive (..) + , ArchiveLocation (..) + + -- ** Repos + , Repo (..) + , RepoType (..) + , withRepo + + -- ** Package location + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + + -- ** Snapshots + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , WantedCompiler (..) + + -- * Loading values + , resolvePaths + , loadPackageRaw + , loadPackage + , loadRawSnapshotLayer + , loadSnapshotLayer + , loadSnapshot + , loadAndCompleteSnapshot + , loadAndCompleteSnapshotRaw + , CompletedSL (..) + , CompletedPLI (..) + , addPackagesToSnapshot + , AddPackagesConfig (..) + + -- * Completion functions + , completePackageLocation + , completeSnapshotLayer + , completeSnapshotLocation + + -- * Parsers + , parseWantedCompiler + , parseRawSnapshotLocation + , parsePackageIdentifierRevision + , parseHackageText + + -- ** Cabal values + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + + -- * Stackage snapshots + , ltsSnapshotLocation + , nightlySnapshotLocation + + -- * Cabal helpers + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , gpdPackageIdentifier + , gpdPackageName + , gpdVersion + + -- * Package location + , fetchPackages + , unpackPackageLocationRaw + , unpackPackageLocation + , getPackageLocationName + , getRawPackageLocationIdent + , packageLocationIdent + , packageLocationVersion + , getRawPackageLocationTreeKey + , getPackageLocationTreeKey + + -- * Cabal files + , loadCabalFileRaw + , loadCabalFile + , loadCabalFileRawImmutable + , loadCabalFileImmutable + , loadCabalFilePath + , findOrGenerateCabalFile + , PrintWarnings (..) + + -- * Hackage index + , updateHackageIndex + , DidUpdateOccur (..) + , RequireHackageIndex (..) + , hackageIndexTarballL + , getHackagePackageVersions + , getLatestHackageVersion + , getLatestHackageLocation + , getLatestHackageRevision + , getHackageTypoCorrections + , loadGlobalHints + , partitionReplacedDependencies + -- * Snapshot cache + , SnapshotCacheHash (..) + , withSnapshotCache + ) where + +import RIO +import Conduit +import Control.Arrow (right) +import Control.Monad.State.Strict (State, execState, get, modify') +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import qualified RIO.ByteString as B +import qualified RIO.Text as T +import qualified RIO.List as List +import qualified RIO.FilePath as FilePath +import Pantry.Archive +import Pantry.Repo +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding (TreeEntry, PackageName, Version) +import Pantry.Tree +import Pantry.Types +import Pantry.Hackage +import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) +import Path.IO (doesFileExist, resolveDir', listDir) +import Distribution.PackageDescription (GenericPackageDescription, FlagName) +import qualified Distribution.PackageDescription as D +import Distribution.Parsec.Common (PWarning (..), showPos) +import qualified Hpack +import qualified Hpack.Config as Hpack +import Network.HTTP.Download +import RIO.PrettyPrint +import RIO.PrettyPrint.StylesUpdate +import RIO.Process +import RIO.Directory (getAppUserDataDirectory) +import qualified Data.Yaml as Yaml +import Pantry.Internal.AesonExtended (WithJSONWarnings (..), Value) +import Data.Aeson.Types (parseEither) +import Data.Monoid (Endo (..)) +import Pantry.HTTP +import Data.Char (isHexDigit) + +-- | Create a new 'PantryConfig' with the given settings. +-- +-- For something easier to use in simple cases, see 'runPantryApp'. +-- +-- @since 0.1.0.0 +withPantryConfig + :: HasLogFunc env + => Path Abs Dir + -- ^ pantry root directory, where the SQLite database and Hackage + -- downloads are kept. + -> HackageSecurityConfig + -- ^ Hackage configuration. You probably want + -- 'defaultHackageSecurityConfig'. + -> HpackExecutable + -- ^ When converting an hpack @package.yaml@ file to a cabal file, + -- what version of hpack should we use? + -> Int + -- ^ Maximum connection count + -> (PantryConfig -> RIO env a) + -- ^ What to do with the config + -> RIO env a +withPantryConfig root hsc he count inner = do + env <- ask + pantryRelFile <- parseRelFile "pantry.sqlite3" + -- Silence persistent's logging output, which is really noisy + runRIO (mempty :: LogFunc) $ initStorage (root pantryRelFile) $ \storage -> runRIO env $ do + ur <- newMVar True + ref1 <- newIORef mempty + ref2 <- newIORef mempty + inner PantryConfig + { pcHackageSecurity = hsc + , pcHpackExecutable = he + , pcRootDir = root + , pcStorage = storage + , pcUpdateRef = ur + , pcConnectionCount = count + , pcParsedCabalFilesRawImmutable = ref1 + , pcParsedCabalFilesMutable = ref2 + } + +-- | Default 'HackageSecurityConfig' value using the official Hackage server. +-- +-- @since 0.1.0.0 +defaultHackageSecurityConfig :: HackageSecurityConfig +defaultHackageSecurityConfig = HackageSecurityConfig + { hscKeyIds = + [ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" + , "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" + , "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833" + , "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201" + , "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" + , "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" + , "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d" + , "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9" + , "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" + ] + , hscKeyThreshold = 3 + , hscDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/" + , hscIgnoreExpiry = False + } + +-- | Returns the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageVersion + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageIdentifierRevision) +getLatestHackageVersion req name preferred = + ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name + where + go (version, m) = do + (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m + pure $ PackageIdentifierRevision name version $ CFIHash sha $ Just size + +-- | Returns location of the latest version of the given package available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> UsePreferredVersions + -> RIO env (Maybe PackageLocationImmutable) +getLatestHackageLocation req name preferred = do + mversion <- + fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name + let mVerCfKey = do + (version, revisions) <- mversion + (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions + pure (version, cfKey) + + forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do + let pir = PackageIdentifierRevision name version (CFIHash sha (Just size)) + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' + +-- | Returns the latest revision of the given package version available from +-- Hackage. +-- +-- @since 0.1.0.0 +getLatestHackageRevision + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> Version + -> RIO env (Maybe (Revision, BlobKey, TreeKey)) +getLatestHackageRevision req name version = do + revisions <- getHackagePackageVersionRevisions req name version + case fmap fst $ Map.maxViewWithKey revisions of + Nothing -> pure Nothing + Just (revision, cfKey@(BlobKey sha size)) -> do + let cfi = CFIHash sha (Just size) + treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi) + return $ Just (revision, cfKey, treeKey') + +fetchTreeKeys + :: (HasPantryConfig env, HasLogFunc env, Foldable f) + => f TreeKey + -> RIO env () +fetchTreeKeys _ = + logWarn "Network caching not yet implemented!" -- TODO pantry wire + +-- | Download all of the packages provided into the local cache +-- without performing any unpacking. Can be useful for build tools +-- wanting to prefetch or provide an offline mode. +-- +-- @since 0.1.0.0 +fetchPackages + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env, Foldable f) + => f PackageLocationImmutable + -> RIO env () +fetchPackages pls = do + fetchTreeKeys $ map getTreeKey $ toList pls + traverseConcurrently_ (void . uncurry getHackageTarball) hackages + -- TODO in the future, be concurrent in these as well + fetchArchives archives + fetchRepos repos + where + s x = Endo (x:) + run (Endo f) = f [] + (hackagesE, archivesE, reposE) = foldMap go pls + hackages = run hackagesE + archives = run archivesE + repos = run reposE + + go (PLIHackage ident cfHash tree) = (s (toPir ident cfHash, Just tree), mempty, mempty) + go (PLIArchive archive pm) = (mempty, s (archive, pm), mempty) + go (PLIRepo repo pm) = (mempty, mempty, s (repo, pm)) + + toPir (PackageIdentifier name ver) (BlobKey sha size) = + PackageIdentifierRevision name ver (CFIHash sha (Just size)) + +-- | Unpack a given 'RawPackageLocationImmutable' into the given +-- directory. Does not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocationRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> RawPackageLocationImmutable + -> RIO env () +unpackPackageLocationRaw fp loc = loadPackageRaw loc >>= unpackTree loc fp . packageTree + +-- | Unpack a given 'PackageLocationImmutable' into the given +-- directory. Does not generate any extra subdirectories. +-- +-- @since 0.1.0.0 +unpackPackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ unpack directory + -> PackageLocationImmutable + -> RIO env () +unpackPackageLocation fp loc = loadPackage loc >>= unpackTree (toRawPLI loc) fp . packageTree + +-- | Load the cabal file for the given 'PackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- Note that, for now, this will not allow support for hpack files in +-- these package locations. Instead, all @PackageLocationImmutable@s +-- will require a .cabal file. This may be relaxed in the future. +-- +-- @since 0.1.0.0 +loadCabalFileImmutable + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadCabalFileBytes loc + let foundCabalKey = bsToBlobKey bs + (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs + let pm = + case loc of + PLIHackage (PackageIdentifier name version) cfHash mtree -> PackageMetadata + { pmIdent = PackageIdentifier name version + , pmTreeKey = mtree + , pmCabal = cfHash + } + PLIArchive _ pm' -> pm' + PLIRepo _ pm' -> pm' + let exc = MismatchedPackageMetadata (toRawPLI loc) (toRawPM pm) Nothing + foundCabalKey (gpdPackageIdentifier gpd) + PackageIdentifier name ver = pmIdent pm + maybe (throwIO exc) pure $ do + guard $ name == gpdPackageName gpd + guard $ ver == gpdVersion gpd + guard $ pmCabal pm == foundCabalKey + pure gpd + where + withCache inner = do + let rawLoc = toRawPLI loc + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup rawLoc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert rawLoc x m, x) + +-- | Load the cabal file for the given 'RawPackageLocationImmutable'. +-- +-- This function ignores all warnings. +-- +-- Note that, for now, this will not allow support for hpack files in +-- these package locations. Instead, all @PackageLocationImmutable@s +-- will require a .cabal file. This may be relaxed in the future. +-- +-- @since 0.1.0.0 +loadCabalFileRawImmutable + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env GenericPackageDescription +loadCabalFileRawImmutable loc = withCache $ do + logDebug $ "Parsing cabal file for " <> display loc + bs <- loadRawCabalFileBytes loc + let foundCabalKey = bsToBlobKey bs + (_warnings, gpd) <- rawParseGPD (Left loc) bs + let rpm = + case loc of + RPLIHackage (PackageIdentifierRevision name version cfi) mtree -> RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version + , rpmTreeKey = mtree + , rpmCabal = + case cfi of + CFIHash sha (Just size) -> Just $ BlobKey sha size + _ -> Nothing + } + RPLIArchive _ rpm' -> rpm' + RPLIRepo _ rpm' -> rpm' + let exc = MismatchedPackageMetadata loc rpm Nothing foundCabalKey (gpdPackageIdentifier gpd) + maybe (throwIO exc) pure $ do + guard $ maybe True (== gpdPackageName gpd) (rpmName rpm) + guard $ maybe True (== gpdVersion gpd) (rpmVersion rpm) + guard $ maybe True (== foundCabalKey) (rpmCabal rpm) + pure gpd + where + withCache inner = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesRawImmutable + m0 <- readIORef ref + case Map.lookup loc m0 of + Just x -> pure x + Nothing -> do + x <- inner + atomicModifyIORef' ref $ \m -> (Map.insert loc x m, x) + +-- | Same as 'loadCabalFileRawImmutable', but takes a +-- 'RawPackageLocation'. Never prints warnings, see 'loadCabalFilePath' +-- for that. +-- +-- @since 0.1.0.0 +loadCabalFileRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocation + -> RIO env GenericPackageDescription +loadCabalFileRaw (RPLImmutable loc) = loadCabalFileRawImmutable loc +loadCabalFileRaw (RPLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Same as 'loadCabalFileImmutable', but takes a +-- 'PackageLocation'. Never prints warnings, see 'loadCabalFilePath' +-- for that. +-- +-- @since 0.1.0.0 +loadCabalFile + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocation + -> RIO env GenericPackageDescription +loadCabalFile (PLImmutable loc) = loadCabalFileImmutable loc +loadCabalFile (PLMutable rfp) = do + (gpdio, _, _) <- loadCabalFilePath (resolvedAbsolute rfp) + liftIO $ gpdio NoPrintWarnings + +-- | Parse the cabal file for the package inside the given +-- directory. Performs various sanity checks, such as the file name +-- being correct and having only a single cabal file. +-- +-- @since 0.1.0.0 +loadCabalFilePath + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ project directory, with a cabal file or hpack file + -> RIO env + ( PrintWarnings -> IO GenericPackageDescription + , PackageName + , Path Abs File + ) +loadCabalFilePath dir = do + ref <- view $ pantryConfigL.to pcParsedCabalFilesMutable + mcached <- Map.lookup dir <$> readIORef ref + case mcached of + Just triple -> pure triple + Nothing -> do + (name, cabalfp) <- findOrGenerateCabalFile dir + gpdRef <- newIORef Nothing + run <- askRunInIO + let gpdio = run . getGPD cabalfp gpdRef + triple = (gpdio, name, cabalfp) + atomicModifyIORef' ref $ \m -> (Map.insert dir triple m, triple) + where + getGPD cabalfp gpdRef printWarnings = do + mpair <- readIORef gpdRef + (warnings0, gpd) <- + case mpair of + Just pair -> pure pair + Nothing -> do + bs <- liftIO $ B.readFile $ toFilePath cabalfp + (warnings0, gpd) <- rawParseGPD (Right cabalfp) bs + checkCabalFileName (gpdPackageName gpd) cabalfp + pure (warnings0, gpd) + warnings <- + case printWarnings of + YesPrintWarnings -> mapM_ (logWarn . toPretty cabalfp) warnings0 $> [] + NoPrintWarnings -> pure warnings0 + writeIORef gpdRef $ Just (warnings, gpd) + pure gpd + + toPretty :: Path Abs File -> PWarning -> Utf8Builder + toPretty src (PWarning _type pos msg) = + "Cabal file warning in" <> + fromString (toFilePath src) <> "@" <> + fromString (showPos pos) <> ": " <> + fromString msg + + -- | Check if the given name in the @Package@ matches the name of the .cabal file + checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () + checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = T.unpack $ unSafeFilePath $ cabalFileName name + when (expected /= toFilePath (filename cabalfp)) + $ throwM $ MismatchedCabalName cabalfp name + +-- | Get the filename for the cabal file in the given directory. +-- +-- If no .cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, hpack is used to +-- generate a .cabal file from it. +-- +-- @since 0.1.0.0 +findOrGenerateCabalFile + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (PackageName, Path Abs File) +findOrGenerateCabalFile pkgDir = do + hpack pkgDir + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . toFilePath . filename) files of + [] -> throwIO $ NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ InvalidCabalFilePath x) + (\pn -> pure $ (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + parsePackageName + _:_ -> throwIO $ MultipleCabalFilesFound pkgDir files + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Generate .cabal file from package.yaml, if necessary. +hpack + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir + -> RIO env () +hpack pkgDir = do + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir packageConfigRelFile + exists <- liftIO $ doesFileExist hpackFile + when exists $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile + Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile <> + " was generated with a newer version of hpack,\n" <> + "please upgrade and try again." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile <> + " was modified manually. Ignoring " <> + fromString (toFilePath hpackFile) <> + " in favor of the cabal file.\nIf you want to use the " <> + fromString (toFilePath (filename hpackFile)) <> + " file instead of the cabal file,\n" <> + "then please delete the cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ + +-- | Get the 'PackageIdentifier' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageIdentifier :: GenericPackageDescription -> PackageIdentifier +gpdPackageIdentifier = D.package . D.packageDescription + +-- | Get the 'PackageName' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdPackageName :: GenericPackageDescription -> PackageName +gpdPackageName = pkgName . gpdPackageIdentifier + +-- | Get the 'Version' from a 'GenericPackageDescription'. +-- +-- @since 0.1.0.0 +gpdVersion :: GenericPackageDescription -> Version +gpdVersion = pkgVersion . gpdPackageIdentifier + +loadCabalFileBytes + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadCabalFileBytes (PLIHackage pident cfHash _mtree) = getHackageCabalFile (pirForHash pident cfHash) + +loadCabalFileBytes pl = do + package <- loadPackage pl + let sfp = cabalFileName $ pkgName $ packageIdent package + cabalBlobKey <- case (packageCabalEntry package) of + PCHpack pcHpack -> pure $ teBlob . phGenerated $ pcHpack + PCCabalFile (TreeEntry blobKey _) -> pure blobKey + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire, try downloading + throwIO $ TreeReferencesMissingBlob (toRawPLI pl) sfp cabalBlobKey + Just bs -> pure bs + +-- FIXME: to be removed +loadRawCabalFileBytes + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env ByteString + +-- Just ignore the mtree for this. Safe assumption: someone who filled +-- in the TreeKey also filled in the cabal file hash, and that's a +-- more efficient lookup mechanism. +loadRawCabalFileBytes (RPLIHackage pir _mtree) = getHackageCabalFile pir + +loadRawCabalFileBytes pl = do + package <- loadPackageRaw pl + let sfp = cabalFileName $ pkgName $ packageIdent package + TreeEntry cabalBlobKey _ft = case packageCabalEntry package of + PCCabalFile cabalTE -> cabalTE + PCHpack hpackCE -> phGenerated hpackCE + mbs <- withStorage $ loadBlob cabalBlobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire, try downloading + throwIO $ TreeReferencesMissingBlob pl sfp cabalBlobKey + Just bs -> pure bs + +-- | Load a 'Package' from a 'PackageLocationImmutable'. +-- +-- @since 0.1.0.0 +loadPackage + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env Package +loadPackage (PLIHackage ident cfHash tree) = + htrPackage <$> getHackageTarball (pirForHash ident cfHash) (Just tree) +loadPackage pli@(PLIArchive archive pm) = getArchivePackage (toRawPLI pli) (toRawArchive archive) (toRawPM pm) +loadPackage (PLIRepo repo pm) = getRepo repo (toRawPM pm) + +-- | Load a 'Package' from a 'RawPackageLocationImmutable'. +-- +-- @since 0.1.0.0 +loadPackageRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env Package +loadPackageRaw (RPLIHackage pir mtree) = htrPackage <$> getHackageTarball pir mtree +loadPackageRaw rpli@(RPLIArchive archive pm) = getArchivePackage rpli archive pm +loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm + +-- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. +-- +-- @since 0.1.0.0 +completePackageLocation + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageLocationImmutable +completePackageLocation (RPLIHackage (PackageIdentifierRevision n v (CFIHash sha (Just size))) (Just tk)) = + pure $ PLIHackage (PackageIdentifier n v) (BlobKey sha size) tk +completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name version cfi0) _) = do + logDebug $ "Completing package location information from " <> display pir0 + (pir, cfKey) <- + case cfi0 of + CFIHash sha (Just size) -> pure (pir0, BlobKey sha size) + _ -> do + bs <- getHackageCabalFile pir0 + let size = FileSize (fromIntegral (B.length bs)) + sha = SHA256.hashBytes bs + cfi = CFIHash sha (Just size) + pir = PackageIdentifierRevision name version cfi + logDebug $ "Added in cabal file hash: " <> display pir + pure (pir, BlobKey sha size) + treeKey' <- getHackageTarballKey pir + pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey' +completePackageLocation pl@(RPLIArchive archive rpm) = do + -- getArchive checks archive and package metadata + (sha, size, package) <- getArchive pl archive rpm + let RawArchive loc _ _ subdir = archive + pure $ PLIArchive (Archive loc sha size subdir) (packagePM package) +completePackageLocation pl@(RPLIRepo repo rpm) = do + unless (isSHA1 (repoCommit repo)) $ throwIO $ CannotCompleteRepoNonSHA1 repo + PLIRepo repo <$> completePM pl rpm + where + isSHA1 t = T.length t == 40 && T.all isHexDigit t + +completePM + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RawPackageMetadata + -> RIO env PackageMetadata +completePM plOrig rpm@(RawPackageMetadata mn mv mtk mc) + | Just n <- mn, Just v <- mv, Just tk <- mtk, Just c <- mc = + pure $ PackageMetadata (PackageIdentifier n v) tk c + | otherwise = do + pm <- packagePM <$> loadPackageRaw plOrig + let isSame x (Just y) = x == y + isSame _ _ = True + + allSame = + isSame (pkgName $ pmIdent pm) (rpmName rpm) && + isSame (pkgVersion $ pmIdent pm) (rpmVersion rpm) && + isSame (pmTreeKey pm) (rpmTreeKey rpm) && + isSame (pmCabal pm) (rpmCabal rpm) + if allSame + then pure pm + else throwIO $ CompletePackageMetadataMismatch plOrig pm + +packagePM :: Package -> PackageMetadata +packagePM package = PackageMetadata + { pmIdent = packageIdent package + , pmTreeKey = packageTreeKey package + , pmCabal = teBlob $ case packageCabalEntry package of + PCCabalFile cfile -> cfile + PCHpack hfile -> phGenerated hfile + } + +-- | Add in hashes to make a 'SnapshotLocation' reproducible. +-- +-- @since 0.1.0.0 +completeSnapshotLocation + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env SnapshotLocation +completeSnapshotLocation (RSLCompiler c) = pure $ SLCompiler c +completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f +completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey +completeSnapshotLocation (RSLUrl url Nothing) = do + bs <- loadFromURL url Nothing + pure $ SLUrl url (bsToBlobKey bs) + +-- | Fill in optional fields in a 'SnapshotLayer' for more reproducible builds. +-- +-- @since 0.1.0.0 +completeSnapshotLayer + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLayer + -> RIO env SnapshotLayer +completeSnapshotLayer rsnapshot = do + parent' <- completeSnapshotLocation $ rslParent rsnapshot + pls <- traverseConcurrently completePackageLocation $ rslLocations rsnapshot + pure SnapshotLayer + { slParent = parent' + , slLocations = pls + , slCompiler= rslCompiler rsnapshot + , slDropPackages = rslDropPackages rsnapshot + , slFlags = rslFlags rsnapshot + , slHidden = rslHidden rsnapshot + , slGhcOptions = rslGhcOptions rsnapshot + , slPublishTime = rslPublishTime rsnapshot + } + +traverseConcurrently_ + :: (Foldable f, HasPantryConfig env) + => (a -> RIO env ()) -- ^ action to perform + -> f a -- ^ input values + -> RIO env () +traverseConcurrently_ f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith_ cnt f t0 + +traverseConcurrentlyWith_ + :: (MonadUnliftIO m, Foldable f) + => Int -- ^ concurrent workers + -> (a -> m ()) -- ^ action to perform + -> f a -- ^ input values + -> m () +traverseConcurrentlyWith_ count f t0 = do + queue <- newTVarIO $ toList t0 + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + (x:rest) -> do + writeTVar queue rest + pure $ do + f x + loop + +traverseConcurrently + :: (HasPantryConfig env, Traversable t) + => (a -> RIO env b) -- ^ action to perform + -> t a -- ^ input values + -> RIO env (t b) +traverseConcurrently f t0 = do + cnt <- view $ pantryConfigL.to pcConnectionCount + traverseConcurrentlyWith cnt f t0 + +-- | Like 'traverse', but does things on +-- up to N separate threads at once. +traverseConcurrentlyWith + :: (MonadUnliftIO m, Traversable t) + => Int -- ^ concurrent workers + -> (a -> m b) -- ^ action to perform + -> t a -- ^ input values + -> m (t b) +traverseConcurrentlyWith count f t0 = do + (queue, t1) <- atomically $ do + queueDList <- newTVar id + t1 <- for t0 $ \x -> do + res <- newEmptyTMVar + modifyTVar queueDList (. ((x, res):)) + pure $ atomically $ takeTMVar res + dlist <- readTVar queueDList + queue <- newTVar $ dlist [] + pure (queue, t1) + + replicateConcurrently_ count $ + fix $ \loop -> join $ atomically $ do + toProcess <- readTVar queue + case toProcess of + [] -> pure (pure ()) + ((x, res):rest) -> do + writeTVar queue rest + pure $ do + y <- f x + atomically $ putTMVar res y + loop + sequence t1 + +-- | Parse a 'RawSnapshot' (all layers) from a 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshotRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> RIO env RawSnapshot +loadSnapshotRaw loc = do + eres <- loadRawSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right (rsl, _) -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | Parse a 'RawSnapshot' (all layers) from a 'SnapshotLocation'. +-- +-- @since 0.1.0.0 +loadSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> RIO env RawSnapshot +loadSnapshot loc = do + eres <- loadSnapshotLayer loc + case eres of + Left wc -> + pure RawSnapshot + { rsCompiler = wc + , rsPackages = mempty + , rsDrop = mempty + } + Right rsl -> do + snap0 <- loadSnapshotRaw $ rslParent rsl + (packages, unused) <- + addPackagesToSnapshot + (display loc) + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (rsPackages snap0) + warnUnusedAddPackagesConfig (display loc) unused + pure RawSnapshot + { rsCompiler = fromMaybe (rsCompiler snap0) (rslCompiler rsl) + , rsPackages = packages + , rsDrop = apcDrop unused + } + +-- | A completed package location, including the original raw and completed information. +-- +-- @since 0.1.0.0 +data CompletedPLI = CompletedPLI !RawPackageLocationImmutable !PackageLocationImmutable + +-- | A completed snapshot location, including the original raw and completed information. +-- +-- @since 0.1.0.0 +data CompletedSL = CompletedSL !RawSnapshotLocation !SnapshotLocation + +-- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting +-- any incomplete package locations +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => SnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot loc cachedSL cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedSL cachedPL + +-- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing +-- any incomplete package locations +-- +-- @since 0.1.0.0 +loadAndCompleteSnapshotRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw rawLoc cacheSL cachePL = do + eres <- case Map.lookup rawLoc cacheSL of + Just loc -> right (\rsl -> (rsl, (CompletedSL rawLoc loc))) <$> loadSnapshotLayer loc + Nothing -> loadRawSnapshotLayer rawLoc + case eres of + Left wc -> + let snapshot = Snapshot + { snapshotCompiler = wc + , snapshotPackages = mempty + , snapshotDrop = mempty + } + in pure (snapshot, [CompletedSL (RSLCompiler wc) (SLCompiler wc)], []) + Right (rsl, sloc) -> do + (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL + (packages, completed, unused) <- + addAndCompletePackagesToSnapshot + rawLoc + cachePL + (rslLocations rsl) + AddPackagesConfig + { apcDrop = rslDropPackages rsl + , apcFlags = rslFlags rsl + , apcHiddens = rslHidden rsl + , apcGhcOptions = rslGhcOptions rsl + } + (snapshotPackages snap0) + warnUnusedAddPackagesConfig (display rawLoc) unused + let snapshot = Snapshot + { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) + , snapshotPackages = packages + , snapshotDrop = apcDrop unused + } + return (snapshot, sloc : slocs,completed0 ++ completed) + +data SingleOrNot a + = Single !a + | Multiple !a !a !([a] -> [a]) +instance Semigroup (SingleOrNot a) where + Single a <> Single b = Multiple a b id + Single a <> Multiple b c d = Multiple a b ((c:) . d) + Multiple a b c <> Single d = Multiple a b (c . (d:)) + Multiple a b c <> Multiple d e f = + Multiple a b (c . (d:) . (e:) . f) + +sonToEither :: (k, SingleOrNot a) -> Either (k, a) (k, [a]) +sonToEither (k, Single a) = Left (k, a) +sonToEither (k, Multiple a b c) = Right (k, (a : b : c [])) + +-- | Package settings to be passed to 'addPackagesToSnapshot'. +-- +-- @since 0.1.0.0 +data AddPackagesConfig = AddPackagesConfig + { apcDrop :: !(Set PackageName) + , apcFlags :: !(Map PackageName (Map FlagName Bool)) + , apcHiddens :: !(Map PackageName Bool) + , apcGhcOptions :: !(Map PackageName [Text]) + } + +-- | Does not warn about drops, those are allowed in order to ignore global +-- packages. +warnUnusedAddPackagesConfig + :: HasLogFunc env + => Utf8Builder -- ^ source + -> AddPackagesConfig + -> RIO env () +warnUnusedAddPackagesConfig source (AddPackagesConfig _drops flags hiddens options) = do + unless (null ls) $ do + logWarn $ "Some warnings discovered when adding packages to snapshot (" <> source <> ")" + traverse_ logWarn ls + where + ls = concat [flags', hiddens', options'] + + flags' = + map + (\pn -> + "Setting flags for non-existent package: " <> + fromString (packageNameString pn)) + (Map.keys flags) + + hiddens' = + map + (\pn -> + "Hiding non-existent package: " <> + fromString (packageNameString pn)) + (Map.keys hiddens) + + options' = + map + (\pn -> + "Setting options for non-existent package: " <> + fromString (packageNameString pn)) + (Map.keys options) + +-- | Add more packages to a snapshot +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used. +-- +-- @since 0.1.0.0 +addPackagesToSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Utf8Builder + -- ^ Text description of where these new packages are coming from, for error + -- messages only + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName RawSnapshotPackage -- ^ packages from parent + -> RIO env (Map PackageName RawSnapshotPackage, AddPackagesConfig) +addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do + new' <- for newPackages $ \loc -> do + name <- getPackageLocationName loc + pure (name, RawSnapshotPackage + { rspLocation = loc + , rspFlags = Map.findWithDefault mempty name flags + , rspHidden = Map.findWithDefault False name hiddens + , rspGhcOptions = Map.findWithDefault [] name options + }) + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) new' + unless (null $ newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map rspLocation)) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name rsp -> + rsp + { rspFlags = Map.findWithDefault (rspFlags rsp) name flags + , rspHidden = Map.findWithDefault (rspHidden rsp) name hiddens + , rspGhcOptions = Map.findWithDefault (rspGhcOptions rsp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, unused) + +cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable + -> RawPackageLocationImmutable + -> RIO env PackageLocationImmutable +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages + case xs of + Nothing -> completePackageLocation rpli + Just x -> pure x + +-- | Add more packages to a snapshot completing their locations if needed +-- +-- Note that any settings on a parent flag which is being replaced will be +-- ignored. For example, if package @foo@ is in the parent and has flag @bar@ +-- set, and @foo@ also appears in new packages, then @bar@ will no longer be +-- set. +-- +-- Returns any of the 'AddPackagesConfig' values not used and also all +-- non-trivial package location completions. +-- +-- @since 0.1.0.0 +addAndCompletePackagesToSnapshot + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -- ^ Text description of where these new packages are coming from, for error + -- messages only + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> [RawPackageLocationImmutable] -- ^ new packages + -> AddPackagesConfig + -> Map PackageName SnapshotPackage -- ^ packages from parent + -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) +addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do + let source = display loc + addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc + let PackageIdentifier name _ = packageLocationIdent complLoc + p = (name, SnapshotPackage + { spLocation = complLoc + , spFlags = Map.findWithDefault mempty name flags + , spHidden = Map.findWithDefault False name hiddens + , spGhcOptions = Map.findWithDefault [] name options + }) + completed' = if toRawPLI complLoc == rawLoc + then completed + else CompletedPLI rawLoc complLoc:completed + pure (p:ps, completed') + (revNew, revCompleted) <- foldM addPackage ([], []) newPackages + let (newSingles, newMultiples) + = partitionEithers + $ map sonToEither + $ Map.toList + $ Map.fromListWith (<>) + $ map (second Single) (reverse revNew) + unless (null $ newMultiples) $ throwIO $ + DuplicatePackageNames source $ map (second (map (toRawPLI . spLocation))) newMultiples + let new = Map.fromList newSingles + allPackages0 = new `Map.union` (old `Map.difference` Map.fromSet (const ()) drops) + allPackages = flip Map.mapWithKey allPackages0 $ \name sp -> + sp + { spFlags = Map.findWithDefault (spFlags sp) name flags + , spHidden = Map.findWithDefault (spHidden sp) name hiddens + , spGhcOptions = Map.findWithDefault (spGhcOptions sp) name options + } + + unused = AddPackagesConfig + (drops `Set.difference` Map.keysSet old) + (flags `Map.difference` allPackages) + (hiddens `Map.difference` allPackages) + (options `Map.difference` allPackages) + + pure (allPackages, reverse revCompleted, unused) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' +-- constructor. Otherwise, returns a 'Right' value providing both the +-- 'Snapshot' and a hash of the input configuration file. +-- +-- @since 0.1.0.0 +loadRawSnapshotLayer + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) +loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler +loadRawSnapshotLayer rsl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + bs <- loadFromURL url blob + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelperRaw rsl value Nothing + pure $ Right (snapshot, (CompletedSL rsl (SLUrl url (bsToBlobKey bs)))) +loadRawSnapshotLayer rsl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot rsl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, CompletedSL rsl (SLFilePath fp)) + +-- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. +-- +-- Returns a 'Left' value if provided an 'SLCompiler' +-- constructor. Otherwise, returns a 'Right' value providing both the +-- 'Snapshot' and a hash of the input configuration file. +-- +-- @since 0.1.0.0 +loadSnapshotLayer + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotLocation + -> RIO env (Either WantedCompiler RawSnapshotLayer) +loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler +loadSnapshotLayer sl@(SLUrl url blob) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + bs <- loadFromURL url (Just blob) + value <- Yaml.decodeThrow bs + snapshot <- warningsParserHelper sl value Nothing + pure $ Right snapshot +loadSnapshotLayer sl@(SLFilePath fp) = + handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right snapshot + +loadFromURL + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadFromURL url Nothing = do + mcached <- withStorage $ loadURLBlob url + case mcached of + Just bs -> return bs + Nothing -> loadWithCheck url Nothing +loadFromURL url (Just bkey) = do + mcached <- withStorage $ loadBlob bkey + case mcached of + Just bs -> return bs + Nothing -> loadWithCheck url (Just bkey) + +loadWithCheck + :: (HasPantryConfig env, HasLogFunc env) + => Text -- ^ url + -> Maybe BlobKey + -> RIO env ByteString +loadWithCheck url mblobkey = do + let (msha, msize) = + case mblobkey of + Nothing -> (Nothing, Nothing) + Just (BlobKey sha size) -> (Just sha, Just size) + (_, _, bss) <- httpSinkChecked url msha msize sinkList + let bs = B.concat bss + withStorage $ storeURLBlob url bs + return bs + +warningsParserHelperRaw + :: HasLogFunc env + => RawSnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelperRaw rsl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot rsl e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display rsl + for_ ws $ logWarn . display + resolvePaths mdir x + +warningsParserHelper + :: HasLogFunc env + => SnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayer +warningsParserHelper sl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot (toRawSL sl) e + Right (WithJSONWarnings x ws) -> do + unless (null ws) $ do + logWarn $ "Warnings when parsing snapshot " <> display sl + for_ ws $ logWarn . display + resolvePaths mdir x + +-- | Get the 'PackageName' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationName + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageName +getPackageLocationName = fmap pkgName . getRawPackageLocationIdent + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationIdent + :: PackageLocationImmutable + -> PackageIdentifier +packageLocationIdent (PLIHackage ident _ _) = ident +packageLocationIdent (PLIRepo _ pm) = pmIdent pm +packageLocationIdent (PLIArchive _ pm) = pmIdent pm + +-- | Get version of the package at the given location. +-- +-- @since 0.1.0.0 +packageLocationVersion + :: PackageLocationImmutable + -> Version +packageLocationVersion (PLIHackage pident _ _) = pkgVersion pident +packageLocationVersion (PLIRepo _ pm) = pkgVersion (pmIdent pm) +packageLocationVersion (PLIArchive _ pm) = pkgVersion (pmIdent pm) + +-- | Get the 'PackageIdentifier' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationIdent + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env PackageIdentifier +getRawPackageLocationIdent (RPLIHackage (PackageIdentifierRevision name version _) _) = pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIRepo _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version +getRawPackageLocationIdent (RPLIArchive _ RawPackageMetadata { rpmName = Just name, rpmVersion = Just version }) = pure $ PackageIdentifier name version +getRawPackageLocationIdent rpli = packageIdent <$> loadPackageRaw rpli + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getRawPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RIO env TreeKey +getRawPackageLocationTreeKey pl = + case getRawTreeKey pl of + Just treeKey' -> pure treeKey' + Nothing -> + case pl of + RPLIHackage pir _ -> getHackageTarballKey pir + RPLIArchive archive pm -> getArchiveKey pl archive pm + RPLIRepo repo pm -> getRepoKey repo pm + +-- | Get the 'TreeKey' of the package at the given location. +-- +-- @since 0.1.0.0 +getPackageLocationTreeKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageLocationImmutable + -> RIO env TreeKey +getPackageLocationTreeKey pl = pure $ getTreeKey pl + +getRawTreeKey :: RawPackageLocationImmutable -> Maybe TreeKey +getRawTreeKey (RPLIHackage _ mtree) = mtree +getRawTreeKey (RPLIArchive _ rpm) = rpmTreeKey rpm +getRawTreeKey (RPLIRepo _ rpm) = rpmTreeKey rpm + +getTreeKey :: PackageLocationImmutable -> TreeKey +getTreeKey (PLIHackage _ _ tree) = tree +getTreeKey (PLIArchive _ pm) = pmTreeKey pm +getTreeKey (PLIRepo _ pm) = pmTreeKey pm + +-- | Convenient data type that allows you to work with pantry more +-- easily than using 'withPantryConfig' directly. Uses basically sane +-- settings, like sharing a pantry directory with Stack. +-- +-- You can use 'runPantryApp' to use this. +-- +-- @since 0.1.0.0 +data PantryApp = PantryApp + { paSimpleApp :: !SimpleApp + , paPantryConfig :: !PantryConfig + , paUseColor :: !Bool + , paTermWidth :: !Int + , paStylesUpdate :: !StylesUpdate + } + +simpleAppL :: Lens' PantryApp SimpleApp +simpleAppL = lens paSimpleApp (\x y -> x { paSimpleApp = y }) + +-- | Lens to view or modify the 'HpackExecutable' of a 'PantryConfig' +-- +-- @since 0.1.0.0 +hpackExecutableL :: Lens' PantryConfig HpackExecutable +hpackExecutableL k pconfig = fmap (\hpExe -> pconfig { pcHpackExecutable = hpExe }) (k (pcHpackExecutable pconfig)) + +instance HasLogFunc PantryApp where + logFuncL = simpleAppL.logFuncL +instance HasPantryConfig PantryApp where + pantryConfigL = lens paPantryConfig (\x y -> x { paPantryConfig = y }) +instance HasProcessContext PantryApp where + processContextL = simpleAppL.processContextL +instance HasStylesUpdate PantryApp where + stylesUpdateL = lens paStylesUpdate (\x y -> x { paStylesUpdate = y }) +instance HasTerm PantryApp where + useColorL = lens paUseColor (\x y -> x { paUseColor = y }) + termWidthL = lens paTermWidth (\x y -> x { paTermWidth = y }) + +-- | Run some code against pantry using basic sane settings. +-- +-- For testing, see 'runPantryAppClean'. +-- +-- @since 0.1.0.0 +runPantryApp :: MonadIO m => RIO PantryApp a -> m a +runPantryApp f = runSimpleApp $ do + sa <- ask + stack <- getAppUserDataDirectory "stack" + root <- parseAbsDir $ stack FilePath. "pantry" + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Like 'runPantryApp', but uses an empty pantry directory instead +-- of sharing with Stack. Useful for testing. +-- +-- @since 0.1.0.0 +runPantryAppClean :: MonadIO m => RIO PantryApp a -> m a +runPantryAppClean f = liftIO $ withSystemTempDirectory "pantry-clean" $ \dir -> runSimpleApp $ do + sa <- ask + root <- resolveDir' dir + withPantryConfig + root + defaultHackageSecurityConfig + HpackBundled + 8 + $ \pc -> + runRIO + PantryApp + { paSimpleApp = sa + , paPantryConfig = pc + , paTermWidth = 100 + , paUseColor = True + , paStylesUpdate = mempty + } + f + +-- | Load the global hints from Github. +-- +-- @since 0.1.0.0 +loadGlobalHints + :: (HasTerm env, HasPantryConfig env) + => WantedCompiler + -> RIO env (Maybe (Map PackageName Version)) +loadGlobalHints wc = + inner False + where + inner alreadyDownloaded = do + dest <- getGlobalHintsFile + req <- parseRequest "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/global-hints.yaml" + downloaded <- download req dest + eres <- tryAny (inner2 dest) + mres <- + case eres of + Left e -> Nothing <$ logError ("Error when parsing global hints: " <> displayShow e) + Right x -> pure x + case mres of + Nothing | not alreadyDownloaded && not downloaded -> do + logInfo $ + "Could not find local global hints for " <> + RIO.display wc <> + ", forcing a redownload" + x <- redownload req dest + if x + then inner True + else do + logInfo "Redownload didn't happen" + pure Nothing + _ -> pure mres + + inner2 dest + = liftIO + $ Map.lookup wc . fmap (fmap unCabalString . unCabalStringMap) + <$> Yaml.decodeFileThrow (toFilePath dest) + +-- | Partition a map of global packages with its versions into a Set of +-- replaced packages and its dependencies and a map of remaining (untouched) packages. +-- +-- @since 0.1.0.0 +partitionReplacedDependencies :: + Ord id + => Map PackageName a -- ^ global packages + -> (a -> PackageName) -- ^ package name getter + -> (a -> id) -- ^ returns unique package id used for dependency pruning + -> (a -> [id]) -- ^ returns unique package ids of direct package dependencies + -> Set PackageName -- ^ overrides which global dependencies should get pruned + -> (Map PackageName [PackageName], Map PackageName a) +partitionReplacedDependencies globals getName getId getDeps overrides = + flip execState (replaced, mempty) $ + for (Map.toList globals) $ prunePackageWithDeps globals' getName getDeps + where + globals' = Map.fromList $ map (getId &&& id) (Map.elems globals) + replaced = Map.map (const []) $ Map.restrictKeys globals overrides + +prunePackageWithDeps :: + Ord id + => Map id a + -> (a -> PackageName) + -> (a -> [id]) + -> (PackageName, a) + -> State (Map PackageName [PackageName], Map PackageName a) Bool +prunePackageWithDeps pkgs getName getDeps (pname, a) = do + (pruned, kept) <- get + if Map.member pname pruned + then return True + else if Map.member pname kept + then return False + else do + let deps = Map.elems $ Map.restrictKeys pkgs (Set.fromList $ getDeps a) + prunedDeps <- forMaybeM deps $ \dep -> do + let depName = getName dep + isPruned <- prunePackageWithDeps pkgs getName getDeps (depName, dep) + pure $ if isPruned then Just depName else Nothing + if null prunedDeps + then do + modify' $ second (Map.insert pname a) + else do + modify' $ first (Map.insert pname prunedDeps) + return $ not (null prunedDeps) + +-- | Use a snapshot cache, which caches which modules are in which +-- packages in a given snapshot. This is mostly intended for usage by +-- Stack. +-- +-- @since 0.1.0.0 +withSnapshotCache + :: (HasPantryConfig env, HasLogFunc env) + => SnapshotCacheHash + -> RIO env (Map PackageName (Set ModuleName)) + -> ((ModuleName -> RIO env [PackageName]) -> RIO env a) + -> RIO env a +withSnapshotCache hash getModuleMapping f = do + mres <- withStorage $ getSnapshotCacheByHash hash + cacheId <- case mres of + Nothing -> do + scId <- withStorage $ getSnapshotCacheId hash + packageModules <- getModuleMapping + logWarn "Populating snapshot module name cache" + withStorage $ storeSnapshotModuleCache scId packageModules + return scId + Just scId -> pure scId + f $ withStorage . loadExposedModulePackages cacheId diff --git a/src/Pantry/Archive.hs b/src/Pantry/Archive.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Archive.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Logic for loading up trees from HTTPS archives. +module Pantry.Archive + ( getArchivePackage + , getArchive + , getArchiveKey + , fetchArchivesRaw + , fetchArchives + ) where + +import RIO +import qualified Pantry.SHA256 as SHA256 +import Pantry.Storage hiding (Tree, TreeEntry) +import Pantry.Tree +import Pantry.Types +import RIO.Process +import Pantry.Internal (normalizeParents, makeTarRelative) +import qualified RIO.Text as T +import qualified RIO.Text.Partial as T +import qualified RIO.List as List +import qualified RIO.ByteString.Lazy as BL +import qualified RIO.Map as Map +import qualified RIO.Set as Set +import qualified Hpack.Config as Hpack +import Pantry.HPack (hpackVersion) +import Data.Bits ((.&.), shiftR) +import Path (toFilePath) +import qualified Codec.Archive.Zip as Zip +import qualified Data.Digest.CRC32 as CRC32 +import Distribution.PackageDescription (packageDescription, package) + +import Conduit +import Data.Conduit.Zlib (ungzip) +import qualified Data.Conduit.Tar as Tar +import Pantry.HTTP + +fetchArchivesRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(RawArchive, RawPackageMetadata)] + -> RIO env () +fetchArchivesRaw pairs = + for_ pairs $ \(ra, rpm) -> + getArchive (RPLIArchive ra rpm) ra rpm + +fetchArchives + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Archive, PackageMetadata)] + -> RIO env () +fetchArchives pairs = + -- TODO be more efficient, group together shared archives + fetchArchivesRaw [ + let PackageIdentifier nm ver = pmIdent pm + rpm = RawPackageMetadata (Just nm) (Just ver) (Just $ pmTreeKey pm) (Just $ pmCabal pm) + ra = RawArchive (archiveLocation a) (Just $ archiveHash a) (Just $ archiveSize a) (archiveSubdir a) + in (ra, rpm) + | (a, pm) <- pairs] + +getArchiveKey + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env TreeKey +getArchiveKey rpli archive rpm = + packageTreeKey <$> getArchivePackage rpli archive rpm -- potential optimization + +thd3 :: (a, b, c) -> c +thd3 (_, _, z) = z + +getArchivePackage + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env Package +getArchivePackage rpli archive rpm = thd3 <$> getArchive rpli archive rpm + +getArchive + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env, HasCallStack) + => RawPackageLocationImmutable -- ^ for exceptions + -> RawArchive + -> RawPackageMetadata + -> RIO env (SHA256, FileSize, Package) +getArchive rpli archive rpm = do + -- Check if the value is in the archive, and use it if possible + mcached <- loadCache rpli archive + cached@(_, _, pa) <- + case mcached of + Just stored -> pure stored + -- Not in the archive. Load the archive. Completely ignore the + -- PackageMetadata for now, we'll check that the Package + -- info matches next. + Nothing -> withArchiveLoc archive $ \fp sha size -> do + pa <- parseArchive rpli archive fp + -- Storing in the cache exclusively uses information we have + -- about the archive itself, not metadata from the user. + storeCache archive sha size pa + pure (sha, size, pa) + + either throwIO (\_ -> pure cached) $ checkPackageMetadata rpli rpm pa + +storeCache + :: forall env. (HasPantryConfig env, HasLogFunc env) + => RawArchive + -> SHA256 + -> FileSize + -> Package + -> RIO env () +storeCache archive sha size pa = + case raLocation archive of + ALUrl url -> withStorage $ storeArchiveCache url (raSubdir archive) sha size (packageTreeKey pa) + ALFilePath _ -> pure () -- TODO cache local as well + +loadCache + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RawArchive + -> RIO env (Maybe (SHA256, FileSize, Package)) +loadCache rpli archive = + case loc of + ALFilePath _ -> pure Nothing -- TODO can we do something intelligent here? + ALUrl url -> withStorage (loadArchiveCache url (raSubdir archive)) >>= loop + where + loc = raLocation archive + msha = raHash archive + msize = raSize archive + + loadFromCache :: TreeId -> RIO env (Maybe Package) + loadFromCache tid = fmap Just $ withStorage $ loadPackageById rpli tid + + loop [] = pure Nothing + loop ((sha, size, tid):rest) = + case msha of + Nothing -> do + case msize of + Just size' | size /= size' -> loop rest + _ -> do + case loc of + ALUrl url -> do + logWarn $ "Using archive from " <> display url <> " without a specified cryptographic hash" + logWarn $ "Cached hash is " <> display sha <> ", file size " <> display size + logWarn "For security and reproducibility, please add a hash and file size to your configuration" + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just sha' + | sha == sha' -> + case msize of + Nothing -> do + case loc of + ALUrl url -> do + logWarn $ "Archive from " <> display url <> " does not specify a size" + logWarn $ "To avoid an overflow attack, please add the file size to your configuration: " <> display size + ALFilePath _ -> pure () + fmap (sha, size,) <$> loadFromCache tid + Just size' + | size == size' -> fmap (sha, size,) <$> loadFromCache tid + | otherwise -> do + + logWarn $ "Archive from " <> display loc <> " has a matching hash but mismatched size" + logWarn "Please verify that your configuration provides the correct size" + loop rest + | otherwise -> loop rest + +-- ensure name, version, etc are correct +checkPackageMetadata + :: RawPackageLocationImmutable + -> RawPackageMetadata + -> Package + -> Either PantryException Package +checkPackageMetadata pl pm pa = do + let + pkgCabal = case packageCabalEntry pa of + PCCabalFile tentry -> tentry + PCHpack phpack -> phGenerated phpack + err = MismatchedPackageMetadata + pl + pm + (Just (packageTreeKey pa)) + (teBlob pkgCabal) + (packageIdent pa) + test (Just x) y = x == y + test Nothing _ = True + + tests = + [ test (rpmTreeKey pm) (packageTreeKey pa) + , test (rpmName pm) (pkgName $ packageIdent pa) + , test (rpmVersion pm) (pkgVersion $ packageIdent pa) + , test (rpmCabal pm) (teBlob pkgCabal) + ] + + in if and tests then Right pa else Left err + +-- | Provide a local file with the contents of the archive, regardless +-- of where it comes from. Perform SHA256 and file size validation if +-- downloading. +withArchiveLoc + :: HasLogFunc env + => RawArchive + -> (FilePath -> SHA256 -> FileSize -> RIO env a) + -> RIO env a +withArchiveLoc (RawArchive (ALFilePath resolved) msha msize _subdir) f = do + let abs' = resolvedAbsolute resolved + fp = toFilePath abs' + (sha, size) <- withBinaryFile fp ReadMode $ \h -> do + size <- FileSize . fromIntegral <$> hFileSize h + for_ msize $ \size' -> when (size /= size') $ throwIO $ LocalInvalidSize abs' Mismatch + { mismatchExpected = size' + , mismatchActual = size + } + + sha <- runConduit (sourceHandle h .| SHA256.sinkHash) + for_ msha $ \sha' -> when (sha /= sha') $ throwIO $ LocalInvalidSHA256 abs' Mismatch + { mismatchExpected = sha' + , mismatchActual = sha + } + + pure (sha, size) + f fp sha size +withArchiveLoc (RawArchive (ALUrl url) msha msize _subdir) f = + withSystemTempFile "archive" $ \fp hout -> do + logDebug $ "Downloading archive from " <> display url + (sha, size, ()) <- httpSinkChecked url msha msize (sinkHandle hout) + hClose hout + f fp sha size + +data ArchiveType = ATTarGz | ATTar | ATZip + deriving (Enum, Bounded) + +instance Display ArchiveType where + display ATTarGz = "GZIP-ed tar file" + display ATTar = "Uncompressed tar file" + display ATZip = "Zip file" + +data METype + = METNormal + | METExecutable + | METLink !FilePath + deriving Show + +data MetaEntry = MetaEntry + { mePath :: !FilePath + , meType :: !METype + } + deriving Show + +foldArchive + :: (HasPantryConfig env, HasLogFunc env) + => ArchiveLocation -- ^ for error reporting + -> FilePath + -> ArchiveType + -> a + -> (a -> MetaEntry -> ConduitT ByteString Void (RIO env) a) + -> RIO env a +foldArchive loc fp ATTarGz accum f = + withSourceFile fp $ \src -> runConduit $ src .| ungzip .| foldTar loc accum f +foldArchive loc fp ATTar accum f = + withSourceFile fp $ \src -> runConduit $ src .| foldTar loc accum f +foldArchive loc fp ATZip accum0 f = withBinaryFile fp ReadMode $ \h -> do + let go accum entry = do + let me = MetaEntry (Zip.eRelativePath entry) met + met = fromMaybe METNormal $ do + let modes = shiftR (Zip.eExternalFileAttributes entry) 16 + guard $ Zip.eVersionMadeBy entry .&. 0xFF00 == 0x0300 + guard $ modes /= 0 + Just $ + if (modes .&. 0o100) == 0 + then METNormal + else METExecutable + lbs = Zip.fromEntry entry + let crcExpected = Zip.eCRC32 entry + crcActual = CRC32.crc32 lbs + when (crcExpected /= crcActual) + $ throwIO $ CRC32Mismatch loc (Zip.eRelativePath entry) Mismatch + { mismatchExpected = crcExpected + , mismatchActual = crcActual + } + runConduit $ sourceLazy lbs .| f accum me + isDir entry = + case reverse $ Zip.eRelativePath entry of + '/':_ -> True + _ -> False + -- We're entering lazy I/O land thanks to zip-archive. + lbs <- BL.hGetContents h + foldM go accum0 (filter (not . isDir) $ Zip.zEntries $ Zip.toArchive lbs) + +foldTar + :: (HasPantryConfig env, HasLogFunc env) + => ArchiveLocation -- ^ for exceptions + -> a + -> (a -> MetaEntry -> ConduitT ByteString o (RIO env) a) + -> ConduitT ByteString o (RIO env) a +foldTar loc accum0 f = do + ref <- newIORef accum0 + Tar.untar $ \fi -> toME fi >>= traverse_ (\me -> do + accum <- readIORef ref + accum' <- f accum me + writeIORef ref $! accum') + readIORef ref + where + toME :: MonadIO m => Tar.FileInfo -> m (Maybe MetaEntry) + toME fi = do + let exc = InvalidTarFileType loc (Tar.getFileInfoPath fi) (Tar.fileType fi) + mmet <- + case Tar.fileType fi of + Tar.FTSymbolicLink bs -> + case decodeUtf8' bs of + Left _ -> throwIO exc + Right text -> pure $ Just $ METLink $ T.unpack text + Tar.FTNormal -> pure $ Just $ + if Tar.fileMode fi .&. 0o100 /= 0 + then METExecutable + else METNormal + Tar.FTDirectory -> pure Nothing + _ -> throwIO exc + pure $ + (\met -> MetaEntry + { mePath = Tar.getFileInfoPath fi + , meType = met + }) + <$> mmet + +data SimpleEntry = SimpleEntry + { seSource :: !FilePath + , seType :: !FileType + } + deriving Show + + +-- | Attempt to parse the contents of the given archive in the given +-- subdir into a 'Tree'. This will not consult any caches. It will +-- ensure that: +-- +-- * The cabal file exists +-- +-- * The cabal file can be parsed +-- +-- * The name inside the cabal file matches the name of the cabal file itself +parseArchive + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> RawArchive + -> FilePath -- ^ file holding the archive + -> RIO env Package +parseArchive rpli archive fp = do + let loc = raLocation archive + getFiles [] = throwIO $ UnknownArchiveType loc + getFiles (at:ats) = do + eres <- tryAny $ foldArchive loc fp at id $ \m me -> pure $ m . (me:) + case eres of + Left e -> do + logDebug $ "parseArchive of " <> display at <> ": " <> displayShow e + getFiles ats + Right files -> pure (at, Map.fromList $ map (mePath &&& id) $ files []) + (at :: ArchiveType, files :: Map FilePath MetaEntry) <- getFiles [minBound..maxBound] + let toSimple :: FilePath -> MetaEntry -> Either String (Map FilePath SimpleEntry) + toSimple key me = + case meType me of + METNormal -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry (mePath me) FTExecutable + METLink relDest -> do + case relDest of + '/':_ -> Left $ concat + [ "File located at " + , show $ mePath me + , " is a symbolic link to absolute path " + , relDest + ] + _ -> Right () + dest0 <- + case makeTarRelative (mePath me) relDest of + Left e -> Left $ concat + [ "Error resolving relative path " + , relDest + , " from symlink at " + , mePath me + , ": " + , e + ] + Right x -> Right x + dest <- + case normalizeParents dest0 of + Left e -> Left $ concat + [ "Invalid symbolic link from " + , mePath me + , " to " + , relDest + , ", tried parsing " + , dest0 + , ": " + , e + ] + Right x -> Right x + -- Check if it's a symlink to a file + case Map.lookup dest files of + Nothing -> + -- Check if it's a symlink to a directory + case findWithPrefix dest files of + [] -> Left $ "Symbolic link dest not found from " ++ mePath me ++ " to " ++ relDest ++ ", looking for " ++ dest ++ ".\n" + ++ "This may indicate that the source is a git archive which uses git-annex.\n" + ++ "See https://github.com/commercialhaskell/stack/issues/4579 for further information." + pairs -> fmap fold $ for pairs $ \(suffix, me') -> toSimple (key ++ '/' : suffix) me' + Just me' -> + case meType me' of + METNormal -> Right $ Map.singleton key $ SimpleEntry dest FTNormal + METExecutable -> Right $ Map.singleton key $ SimpleEntry dest FTExecutable + METLink _ -> Left $ "Symbolic link dest cannot be a symbolic link, from " ++ mePath me ++ " to " ++ relDest + + case fold <$> Map.traverseWithKey toSimple files of + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e + Right files1 -> do + let files2 = stripCommonPrefix $ Map.toList files1 + files3 = takeSubdir (raSubdir archive) files2 + toSafe (fp', a) = + case mkSafeFilePath fp' of + Nothing -> Left $ "Not a safe file path: " ++ show fp' + Just sfp -> Right (sfp, a) + case traverse toSafe files3 of + Left e -> throwIO $ UnsupportedTarball loc $ T.pack e + Right safeFiles -> do + let toSave = Set.fromList $ map (seSource . snd) safeFiles + (blobs :: Map FilePath BlobKey) <- + foldArchive loc fp at mempty $ \m me -> + if mePath me `Set.member` toSave + then do + bs <- mconcat <$> sinkList + (_, blobKey) <- lift $ withStorage $ storeBlob bs + pure $ Map.insert (mePath me) blobKey m + else pure m + tree <- fmap (TreeMap . Map.fromList) $ for safeFiles $ \(sfp, se) -> + case Map.lookup (seSource se) blobs of + Nothing -> error $ "Impossible: blob not found for: " ++ seSource se + Just blobKey -> pure (sfp, TreeEntry blobKey (seType se)) + -- parse the cabal file and ensure it has the right name + buildFile <- findCabalOrHpackFile rpli tree + (buildFilePath, buildFileBlobKey, buildFileEntry) <- case buildFile of + BFCabal fpath te@(TreeEntry key _) -> pure (fpath, key, te) + BFHpack te@(TreeEntry key _) -> pure (hpackSafeFilePath, key, te) + mbs <- withStorage $ loadBlob buildFileBlobKey + bs <- + case mbs of + Nothing -> throwIO $ TreeReferencesMissingBlob rpli buildFilePath buildFileBlobKey + Just bs -> pure bs + cabalBs <- case buildFile of + BFCabal _ _ -> pure bs + BFHpack _ -> snd <$> hpackToCabal rpli tree + (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBs + let ident@(PackageIdentifier name _) = package $ packageDescription gpd + case buildFile of + BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name + _ -> return () + -- It's good! Store the tree, let's bounce + (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile + packageCabal <- case buildFile of + BFCabal _ _ -> pure $ PCCabalFile buildFileEntry + BFHpack _ -> do + cabalKey <- withStorage $ do + hpackId <- storeHPack rpli tid + loadCabalBlobKey hpackId + hpackSoftwareVersion <- hpackVersion + let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry) + pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion} + pure Package + { packageTreeKey = treeKey' + , packageTree = tree + , packageCabalEntry = packageCabal + , packageIdent = ident + } + +-- | Find all of the files in the Map with the given directory as a +-- prefix. Directory is given without trailing slash. Returns the +-- suffix after stripping the given prefix. +findWithPrefix :: FilePath -> Map FilePath MetaEntry -> [(FilePath, MetaEntry)] +findWithPrefix dir = mapMaybe go . Map.toList + where + prefix = dir ++ "/" + go (x, y) = (, y) <$> List.stripPrefix prefix x + +findCabalOrHpackFile + :: MonadThrow m + => RawPackageLocationImmutable -- ^ for exceptions + -> Tree + -> m BuildFile +findCabalOrHpackFile loc (TreeMap m) = do + let isCabalFile (sfp, _) = + let txt = unSafeFilePath sfp + in not ("/" `T.isInfixOf` txt) && (".cabal" `T.isSuffixOf` txt) + isHpackFile (sfp, _) = + let txt = unSafeFilePath sfp + in T.pack (Hpack.packageConfig) == txt + isBFCabal (BFCabal _ _) = True + isBFCabal _ = False + sfpBuildFile (BFCabal sfp _) = sfp + sfpBuildFile (BFHpack _) = hpackSafeFilePath + toBuildFile xs@(sfp, te) = let cbFile = if (isCabalFile xs) + then Just $ BFCabal sfp te + else Nothing + hpFile = if (isHpackFile xs) + then Just $ BFHpack te + else Nothing + in cbFile <|> hpFile + case mapMaybe toBuildFile $ Map.toList m of + [] -> throwM $ TreeWithoutCabalFile loc + [bfile] -> pure bfile + xs -> case (filter isBFCabal xs) of + [] -> throwM $ TreeWithoutCabalFile loc + [bfile] -> pure bfile + xs' -> throwM $ TreeWithMultipleCabalFiles loc $ map sfpBuildFile xs' + +-- | If all files have a shared prefix, strip it off +stripCommonPrefix :: [(FilePath, a)] -> [(FilePath, a)] +stripCommonPrefix [] = [] +stripCommonPrefix pairs@((firstFP, _):_) = fromMaybe pairs $ do + let firstDir = takeWhile (/= '/') firstFP + guard $ not $ null firstDir + let strip (fp, a) = (, a) <$> List.stripPrefix (firstDir ++ "/") fp + stripCommonPrefix <$> traverse strip pairs + +-- | Take us down to the specified subdirectory +takeSubdir + :: Text -- ^ subdir + -> [(FilePath, a)] -- ^ files after stripping common prefix + -> [(Text, a)] +takeSubdir subdir = mapMaybe $ \(fp, a) -> do + stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp + Just (T.intercalate "/" stripped, a) + where + splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" + subdirs = splitDirs subdir diff --git a/src/Pantry/HPack.hs b/src/Pantry/HPack.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/HPack.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +module Pantry.HPack + ( + hpack + , hpackVersion + ) where + +import RIO +import RIO.Process +import Pantry.Types +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Hpack +import qualified Hpack.Config as Hpack +import Data.Char (isSpace, isDigit) +import Path (Path, Abs, toFilePath, Dir, (), filename, parseRelFile) +import Path.IO (doesFileExist) + + +hpackVersion + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RIO env Version +hpackVersion = do + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + let bundledHpackVersion :: String = VERSION_hpack + parseVersionThrowing bundledHpackVersion + HpackCommand command -> do + version <- BL.unpack <$> proc command ["--version"] readProcessStdout_ + let version' = dropWhile (not . isDigit) version + version'' = filter (not . isSpace) version' + parseVersionThrowing version'' + +-- | Generate .cabal file from package.yaml, if necessary. +hpack + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir + -> RIO env () +hpack pkgDir = do + packageConfigRelFile <- parseRelFile Hpack.packageConfig + let hpackFile = pkgDir Path. packageConfigRelFile + whenM (doesFileExist hpackFile) $ do + logDebug $ "Running hpack on " <> fromString (toFilePath hpackFile) + + he <- view $ pantryConfigL.to pcHpackExecutable + case he of + HpackBundled -> do + r <- liftIO $ Hpack.hpackResult $ Hpack.setProgramName "stack" $ Hpack.setTarget (toFilePath hpackFile) Hpack.defaultOptions + forM_ (Hpack.resultWarnings r) (logWarn . fromString) + let cabalFile = fromString . Hpack.resultCabalFile $ r + case Hpack.resultStatus r of + Hpack.Generated -> logDebug $ "hpack generated a modified version of " <> cabalFile + Hpack.OutputUnchanged -> logDebug $ "hpack output unchanged in " <> cabalFile + Hpack.AlreadyGeneratedByNewerHpack -> logWarn $ + cabalFile <> + " was generated with a newer version of hpack,\n" <> + "please upgrade and try again." + Hpack.ExistingCabalFileWasModifiedManually -> logWarn $ + cabalFile <> + " was modified manually. Ignoring " <> + fromString (toFilePath hpackFile) <> + " in favor of the cabal file.\nIf you want to use the " <> + fromString (toFilePath (filename hpackFile)) <> + " file instead of the cabal file,\n" <> + "then please delete the cabal file." + HpackCommand command -> + withWorkingDir (toFilePath pkgDir) $ + proc command [] runProcess_ diff --git a/src/Pantry/HTTP.hs b/src/Pantry/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/HTTP.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.HTTP + ( module Export + , withResponse + , httpSink + , httpSinkChecked + ) where + +import Conduit +import Network.HTTP.Client as Export (parseRequest) +import Network.HTTP.Client as Export (parseUrlThrow) +import Network.HTTP.Client as Export (BodyReader, HttpExceptionContent (StatusCodeException)) +import qualified Network.HTTP.Client as HTTP (withResponse) +import Network.HTTP.Client.Internal as Export (setUri) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.HTTP.Simple as Export (HttpException (..), + Request, Response, + addRequestHeader, + defaultRequest, + getResponseBody, + getResponseHeaders, + getResponseStatus, + setRequestHeader, + setRequestHeaders) +import qualified Network.HTTP.Simple as HTTP hiding (withResponse) +import Network.HTTP.Types as Export (Header, HeaderName, + Status, hCacheControl, + hRange, ok200, + partialContent206, + statusCode) +import qualified Pantry.SHA256 as SHA256 +import Pantry.Types +import RIO +import qualified RIO.ByteString as B +import qualified RIO.Text as T + +setUserAgent :: Request -> Request +setUserAgent = setRequestHeader "User-Agent" ["Haskell pantry package"] + +withResponse + :: MonadUnliftIO m + => HTTP.Request + -> (Response BodyReader -> m a) + -> m a +withResponse req inner = withRunInIO $ \run -> do + manager <- getGlobalManager + HTTP.withResponse (setUserAgent req) manager (run . inner) + +httpSink + :: MonadUnliftIO m + => Request + -> (Response () -> ConduitT ByteString Void m a) + -> m a +httpSink req inner = HTTP.httpSink (setUserAgent req) inner + +httpSinkChecked + :: MonadUnliftIO m + => Text + -> Maybe SHA256 + -> Maybe FileSize + -> ConduitT ByteString Void m a + -> m (SHA256, FileSize, a) +httpSinkChecked url msha msize sink = do + req <- liftIO $ parseUrlThrow $ T.unpack url + httpSink req $ const $ getZipSink $ (,,) + <$> ZipSink (checkSha msha) + <*> ZipSink (checkSize msize) + <*> ZipSink sink + where + checkSha mexpected = do + actual <- SHA256.sinkHash + for_ mexpected $ \expected -> unless (actual == expected) $ + throwIO $ DownloadInvalidSHA256 url Mismatch + { mismatchExpected = expected + , mismatchActual = actual + } + pure actual + checkSize mexpected = + loop 0 + where + loop accum = do + mbs <- await + case mbs of + Nothing -> + case mexpected of + Just (FileSize expected) | expected /= accum -> + throwIO $ DownloadInvalidSize url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum + } + _ -> pure (FileSize accum) + Just bs -> do + let accum' = accum + fromIntegral (B.length bs) + case mexpected of + Just (FileSize expected) + | accum' > expected -> + throwIO $ DownloadTooLarge url Mismatch + { mismatchExpected = FileSize expected + , mismatchActual = FileSize accum' + } + _ -> loop accum' diff --git a/src/Pantry/Hackage.hs b/src/Pantry/Hackage.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Hackage.hs @@ -0,0 +1,629 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pantry.Hackage + ( updateHackageIndex + , forceUpdateHackageIndex + , DidUpdateOccur (..) + , RequireHackageIndex (..) + , hackageIndexTarballL + , getHackageTarball + , getHackageTarballKey + , getHackageCabalFile + , getHackagePackageVersions + , getHackagePackageVersionRevisions + , getHackageTypoCorrections + , UsePreferredVersions (..) + , HackageTarballResult(..) + ) where + +import RIO +import RIO.Process +import Data.Aeson +import Conduit +import Data.Conduit.Tar +import qualified RIO.Text as T +import qualified RIO.Map as Map +import Data.Text.Unsafe (unsafeTail) +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import Pantry.Archive +import Pantry.Types hiding (FileType (..)) +import Pantry.Storage hiding (TreeEntry, PackageName, Version) +import Pantry.Tree +import qualified Pantry.SHA256 as SHA256 +import Network.URI (parseURI) +import Data.Time (getCurrentTime) +import Path ((), Path, Abs, Rel, Dir, File, toFilePath, parseRelDir, parseRelFile) +import qualified Distribution.Text +import qualified Distribution.PackageDescription as Cabal +import System.IO (SeekMode (..)) +import qualified Data.List.NonEmpty as NE +import Data.Text.Metrics (damerauLevenshtein) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.Types.Version (versionNumbers) +import Distribution.Types.VersionRange (withinRange) + +import qualified Hackage.Security.Client as HS +import qualified Hackage.Security.Client.Repository.Cache as HS +import qualified Hackage.Security.Client.Repository.Remote as HS +import qualified Hackage.Security.Client.Repository.HttpLib.HttpClient as HS +import qualified Hackage.Security.Util.Path as HS +import qualified Hackage.Security.Util.Pretty as HS + +hackageRelDir :: Path Rel Dir +hackageRelDir = either impureThrow id $ parseRelDir "hackage" + +hackageDirL :: HasPantryConfig env => SimpleGetter env (Path Abs Dir) +hackageDirL = pantryConfigL.to (( hackageRelDir) . pcRootDir) + +indexRelFile :: Path Rel File +indexRelFile = either impureThrow id $ parseRelFile "00-index.tar" + +-- | Where does pantry download its 01-index.tar file from Hackage? +-- +-- @since 0.1.0.0 +hackageIndexTarballL :: HasPantryConfig env => SimpleGetter env (Path Abs File) +hackageIndexTarballL = hackageDirL.to ( indexRelFile) + +-- | Did an update occur when running 'updateHackageIndex'? +-- +-- @since 0.1.0.0 +data DidUpdateOccur = UpdateOccurred | NoUpdateOccurred + + +-- | Information returned by `getHackageTarball` +-- +-- @since 0.1.0.0 +data HackageTarballResult = HackageTarballResult + { htrPackage :: !Package + -- ^ Package that was loaded from Hackage tarball + , htrFreshPackageInfo :: !(Maybe (GenericPackageDescription, TreeId)) + -- ^ This information is only available whenever package was just loaded into pantry. + } + +-- | Download the most recent 01-index.tar file from Hackage and +-- update the database tables. +-- +-- This function will only perform an update once per 'PantryConfig' +-- for user sanity. See the return value to find out if it happened. +-- +-- @since 0.1.0.0 +updateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndex = updateHackageIndexInternal False + +-- | Same as `updateHackageIndex`, but force the database update even if hackage +-- security tells that there is no change. This can be useful in order to make +-- sure the database is in sync with the locally downloaded tarball +-- +-- @since 0.1.0.0 +forceUpdateHackageIndex + :: (HasPantryConfig env, HasLogFunc env) + => Maybe Utf8Builder + -> RIO env DidUpdateOccur +forceUpdateHackageIndex = updateHackageIndexInternal True + + +updateHackageIndexInternal + :: (HasPantryConfig env, HasLogFunc env) + => Bool -- ^ Force the database update. + -> Maybe Utf8Builder -- ^ reason for updating, if any + -> RIO env DidUpdateOccur +updateHackageIndexInternal forceUpdate mreason = do + storage <- view $ pantryConfigL.to pcStorage + gateUpdate $ withWriteLock_ storage $ do + for_ mreason logInfo + pc <- view pantryConfigL + let HackageSecurityConfig keyIds threshold url ignoreExpiry = pcHackageSecurity pc + root <- view hackageDirL + tarball <- view hackageIndexTarballL + baseURI <- + case parseURI $ T.unpack url of + Nothing -> throwString $ "Invalid Hackage Security base URL: " ++ T.unpack url + Just x -> return x + run <- askRunInIO + let logTUF = run . logInfo . fromString . HS.pretty + withRepo = HS.withRepository + HS.httpLib + [baseURI] + HS.defaultRepoOpts + HS.Cache + { HS.cacheRoot = HS.fromAbsoluteFilePath $ toFilePath root + , HS.cacheLayout = HS.cabalCacheLayout + } + HS.hackageRepoLayout + HS.hackageIndexLayout + logTUF + didUpdate <- liftIO $ withRepo $ \repo -> HS.uncheckClientErrors $ do + needBootstrap <- HS.requiresBootstrap repo + when needBootstrap $ do + HS.bootstrap + repo + (map (HS.KeyId . T.unpack) keyIds) + (HS.KeyThreshold $ fromIntegral threshold) + maybeNow <- if ignoreExpiry + then pure Nothing + else Just <$> getCurrentTime + HS.checkForUpdates repo maybeNow + + case didUpdate of + _ | forceUpdate -> do + logInfo "Forced package update is initialized" + updateCache tarball + HS.NoUpdates -> do + x <- needsCacheUpdate tarball + if x + then do + logInfo "No package index update available, but didn't update cache last time, running now" + updateCache tarball + else logInfo "No package index update available and cache up to date" + HS.HasUpdates -> do + logInfo "Updated package index downloaded" + updateCache tarball + logStickyDone "Package index cache populated" + where + -- The size of the new index tarball, ignoring the required + -- (by the tar spec) 1024 null bytes at the end, which will be + -- mutated in the future by other updates. + getTarballSize :: MonadIO m => Handle -> m Word + getTarballSize h = (fromIntegral . max 0 . subtract 1024) <$> hFileSize h + + -- Check if the size of the tarball on the disk matches the value + -- in CacheUpdate. If not, we need to perform a cache update, even + -- if we didn't download any new information. This can be caused + -- by canceling an updateCache call. + needsCacheUpdate tarball = do + mres <- withStorage loadLatestCacheUpdate + case mres of + Nothing -> pure True + Just (FileSize cachedSize, _sha256) -> do + actualSize <- withBinaryFile (toFilePath tarball) ReadMode getTarballSize + pure $ cachedSize /= actualSize + + -- This is the one action in the Pantry codebase known to hold a + -- write lock on the database for an extended period of time. To + -- avoid failures due to SQLite locks failing, we take our own + -- lock outside of SQLite for this action. + -- + -- See https://github.com/commercialhaskell/stack/issues/4471 + updateCache tarball = withStorage $ do + -- Alright, here's the story. In theory, we only ever append to + -- a tarball. Therefore, we can store the last place we + -- populated our cache from, and fast forward to that point. But + -- there are two issues with that: + -- + -- 1. Hackage may rebase, in which case we need to recalculate + -- everything from the beginning. Unfortunately, + -- hackage-security doesn't let us know when that happens. + -- + -- 2. Some paranoia about files on the filesystem getting + -- modified out from under us. + -- + -- Therefore, we store both the last read-to index, _and_ the + -- SHA256 of all of the contents until that point. When updating + -- the cache, we calculate the new SHA256 of the whole file, and + -- the SHA256 of the previous read-to point. If the old hashes + -- match, we can do an efficient fast forward. Otherwise, we + -- clear the old cache and repopulate. + minfo <- loadLatestCacheUpdate + (offset, newHash, newSize) <- lift $ withBinaryFile (toFilePath tarball) ReadMode $ \h -> do + logInfo "Calculating hashes to check for hackage-security rebases or filesystem changes" + + newSize <- getTarballSize h + let sinkSHA256 len = takeCE (fromIntegral len) .| SHA256.sinkHash + + case minfo of + Nothing -> do + logInfo "No old cache found, populating cache from scratch" + newHash <- runConduit $ sourceHandle h .| sinkSHA256 newSize + pure (0, newHash, newSize) + Just (FileSize oldSize, oldHash) -> do + -- oldSize and oldHash come from the database, and tell + -- us what we cached already. Compare against + -- oldHashCheck, which assuming the tarball has not been + -- rebased will be the same as oldHash. At the same + -- time, calculate newHash, which is the hash of the new + -- content as well. + (oldHashCheck, newHash) <- runConduit $ sourceHandle h .| getZipSink ((,) + <$> ZipSink (sinkSHA256 oldSize) + <*> ZipSink (sinkSHA256 newSize) + ) + offset <- + if oldHash == oldHashCheck + then oldSize <$ logInfo "Updating preexisting cache, should be quick" + else 0 <$ do + logWarn $ mconcat [ + "Package index change detected, that's pretty unusual: " + , "\n Old size: " <> display oldSize + , "\n Old hash (orig) : " <> display oldHash + , "\n New hash (check): " <> display oldHashCheck + , "\n Forcing a recache" + ] + pure (offset, newHash, newSize) + + lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash + when (offset == 0) clearHackageRevisions + populateCache tarball (fromIntegral offset) `onException` + lift (logStickyDone "Failed populating package index cache") + storeCacheUpdate (FileSize newSize) newHash + gateUpdate inner = do + pc <- view pantryConfigL + join $ modifyMVar (pcUpdateRef pc) $ \toUpdate -> pure $ + if toUpdate + then (False, UpdateOccurred <$ inner) + else (False, pure NoUpdateOccurred) + +-- | Populate the SQLite tables with Hackage index information. +populateCache + :: (HasPantryConfig env, HasLogFunc env) + => Path Abs File -- ^ tarball + -> Integer -- ^ where to start processing from + -> ReaderT SqlBackend (RIO env) () +populateCache fp offset = withBinaryFile (toFilePath fp) ReadMode $ \h -> do + lift $ logInfo "Populating package index cache ..." + counter <- newIORef (0 :: Int) + hSeek h AbsoluteSeek offset + runConduit $ sourceHandle h .| untar (perFile counter) + where + + perFile counter fi + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , Just (name, version, filename) <- parseNameVersionSuffix path = + if + | filename == "package.json" -> + sinkLazy >>= lift . addJSON name version + | filename == unSafeFilePath (cabalFileName name) -> do + (BL.toStrict <$> sinkLazy) >>= lift . addCabal name version + + count <- readIORef counter + let count' = count + 1 + writeIORef counter count' + when (count' `mod` 400 == 0) $ + lift $ lift $ + logSticky $ "Processed " <> display count' <> " cabal files" + | otherwise -> pure () + | FTNormal <- fileType fi + , Right path <- decodeUtf8' $ filePath fi + , (nameT, "/preferred-versions") <- T.break (== '/') path + , Just name <- parsePackageName $ T.unpack nameT = do + lbs <- sinkLazy + case decodeUtf8' $ BL.toStrict lbs of + Left _ -> pure () -- maybe warning + Right p -> lift $ storePreferredVersion name p + | otherwise = pure () + + addJSON name version lbs = + case eitherDecode' lbs of + Left e -> lift $ logError $ + "Error processing Hackage security metadata for " <> + fromString (Distribution.Text.display name) <> "-" <> + fromString (Distribution.Text.display version) <> ": " <> + fromString e + Right (PackageDownload sha size) -> + storeHackageTarballInfo name version sha $ FileSize size + + addCabal name version bs = do + (blobTableId, _blobKey) <- storeBlob bs + + storeHackageRevision name version blobTableId + + breakSlash x + | T.null z = Nothing + | otherwise = Just (y, unsafeTail z) + where + (y, z) = T.break (== '/') x + + parseNameVersionSuffix t1 = do + (name, t2) <- breakSlash t1 + (version, filename) <- breakSlash t2 + + name' <- Distribution.Text.simpleParse $ T.unpack name + version' <- Distribution.Text.simpleParse $ T.unpack version + + Just (name', version', filename) + +-- | Package download info from Hackage +data PackageDownload = PackageDownload !SHA256 !Word +instance FromJSON PackageDownload where + parseJSON = withObject "PackageDownload" $ \o1 -> do + o2 <- o1 .: "signed" + Object o3 <- o2 .: "targets" + Object o4:_ <- return $ toList o3 + len <- o4 .: "length" + hashes <- o4 .: "hashes" + sha256' <- hashes .: "sha256" + sha256 <- + case SHA256.fromHexText sha256' of + Left e -> fail $ "Invalid sha256: " ++ show e + Right x -> return x + return $ PackageDownload sha256 len + +getHackageCabalFile + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env ByteString +getHackageCabalFile pir@(PackageIdentifierRevision _ _ cfi) = do + bid <- resolveCabalFileInfo pir + bs <- withStorage $ loadBlobById bid + case cfi of + CFIHash sha msize -> do + let sizeMismatch = + case msize of + Nothing -> False + Just size -> FileSize (fromIntegral (B.length bs)) /= size + shaMismatch = sha /= SHA256.hashBytes bs + when (sizeMismatch || shaMismatch) + $ error $ "getHackageCabalFile: size or SHA mismatch for " ++ show (pir, bs) + _ -> pure () + pure bs + +resolveCabalFileInfo + :: (HasPantryConfig env, HasLogFunc env) + => PackageIdentifierRevision + -> RIO env BlobId +resolveCabalFileInfo pir@(PackageIdentifierRevision name ver cfi) = do + mres <- inner + case mres of + Just res -> pure res + Nothing -> do + updated <- updateHackageIndex $ Just $ "Cabal file info not found for " <> display pir <> ", updating" + mres' <- + case updated of + UpdateOccurred -> inner + NoUpdateOccurred -> pure Nothing + case mres' of + Nothing -> fuzzyLookupCandidates name ver >>= throwIO . UnknownHackagePackage pir + Just res -> pure res + where + inner = + case cfi of + CFIHash sha _msize -> withStorage $ loadBlobBySHA sha + CFIRevision rev -> (fmap fst . Map.lookup rev) <$> withStorage (loadHackagePackageVersion name ver) + CFILatest -> (fmap (fst . fst) . Map.maxView) <$> withStorage (loadHackagePackageVersion name ver) + +-- | Given package identifier and package caches, return list of packages +-- with the same name and the same two first version number components found +-- in the caches. +fuzzyLookupCandidates + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> Version + -> RIO env FuzzyResults +fuzzyLookupCandidates name ver0 = do + m <- getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions name + if Map.null m + then FRNameNotFound <$> getHackageTypoCorrections name + else + case Map.lookup ver0 m of + Nothing -> do + let withVers vers = pure $ FRVersionNotFound $ flip NE.map vers $ \(ver, revs) -> + case Map.maxView revs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just (BlobKey sha size, _) -> PackageIdentifierRevision name ver (CFIHash sha (Just size)) + case NE.nonEmpty $ filter (sameMajor . fst) $ Map.toList m of + Just vers -> withVers vers + Nothing -> + case NE.nonEmpty $ Map.toList m of + Nothing -> error "fuzzyLookupCandidates: no versions" + Just vers -> withVers vers + Just revisions -> + let pirs = map + (\(BlobKey sha size) -> PackageIdentifierRevision name ver0 (CFIHash sha (Just size))) + (Map.elems revisions) + in case NE.nonEmpty pirs of + Nothing -> error "fuzzyLookupCandidates: no revisions" + Just pirs' -> pure $ FRRevisionNotFound pirs' + where + sameMajor v = toMajorVersion v == toMajorVersion ver0 + +toMajorVersion :: Version -> [Int] +toMajorVersion v = + case versionNumbers v of + [] -> [0, 0] + [a] -> [a, 0] + a:b:_ -> [a, b] + +-- | Try to come up with typo corrections for given package identifier +-- using Hackage package names. This can provide more user-friendly +-- information in error messages. +-- +-- @since 0.1.0.0 +getHackageTypoCorrections + :: (HasPantryConfig env, HasLogFunc env) + => PackageName + -> RIO env [PackageName] +getHackageTypoCorrections name1 = + withStorage $ sinkHackagePackageNames + (\name2 -> name1 `distance` name2 < 4) + (takeC 10 .| sinkList) + where + distance = damerauLevenshtein `on` (T.pack . packageNameString) + +-- | Should we pay attention to Hackage's preferred versions? +-- +-- @since 0.1.0.0 +data UsePreferredVersions = UsePreferredVersions | IgnorePreferredVersions + deriving Show + +-- | Require that the Hackage index is populated. +-- +-- @since 0.1.0.0 +data RequireHackageIndex + = YesRequireHackageIndex + -- ^ If there is nothing in the Hackage index, then perform an update + | NoRequireHackageIndex + -- ^ Do not perform an update + deriving Show + +initializeIndex + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> RIO env () +initializeIndex NoRequireHackageIndex = pure () +initializeIndex YesRequireHackageIndex = do + cabalCount <- withStorage countHackageCabals + when (cabalCount == 0) $ void $ + updateHackageIndex $ Just $ "No information from Hackage index, updating" + +-- | Returns the versions of the package available on Hackage. +-- +-- @since 0.1.0.0 +getHackagePackageVersions + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> UsePreferredVersions + -> PackageName -- ^ package name + -> RIO env (Map Version (Map Revision BlobKey)) +getHackagePackageVersions req usePreferred name = do + initializeIndex req + withStorage $ do + mpreferred <- + case usePreferred of + UsePreferredVersions -> loadPreferredVersion name + IgnorePreferredVersions -> pure Nothing + let predicate :: Version -> Map Revision BlobKey -> Bool + predicate = fromMaybe (\_ _ -> True) $ do + preferredT1 <- mpreferred + preferredT2 <- T.stripPrefix (T.pack $ packageNameString name) preferredT1 + vr <- Distribution.Text.simpleParse $ T.unpack preferredT2 + Just $ \v _ -> withinRange v vr + Map.filterWithKey predicate <$> loadHackagePackageVersions name + +-- | Returns the versions of the package available on Hackage. +-- +-- @since 0.1.0.0 +getHackagePackageVersionRevisions + :: (HasPantryConfig env, HasLogFunc env) + => RequireHackageIndex + -> PackageName -- ^ package name + -> Version -- ^ package version + -> RIO env (Map Revision BlobKey) +getHackagePackageVersionRevisions req name version = do + initializeIndex req + withStorage $ + Map.map snd <$> loadHackagePackageVersion name version + +withCachedTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocationImmutable + -> PackageName + -> Version + -> BlobId -- ^ cabal file contents + -> RIO env HackageTarballResult + -> RIO env HackageTarballResult +withCachedTree rpli name ver bid inner = do + mres <- withStorage $ loadHackageTree rpli name ver bid + case mres of + Just package -> pure $ HackageTarballResult package Nothing + Nothing -> do + htr <- inner + withStorage $ + storeHackageTree name ver bid $ packageTreeKey $ htrPackage htr + pure htr + +getHackageTarballKey + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageIdentifierRevision + -> RIO env TreeKey +getHackageTarballKey pir@(PackageIdentifierRevision name ver (CFIHash sha _msize)) = do + mres <- withStorage $ loadHackageTreeKey name ver sha + case mres of + Nothing -> packageTreeKey . htrPackage <$> getHackageTarball pir Nothing + Just key -> pure key +getHackageTarballKey pir = packageTreeKey . htrPackage <$> getHackageTarball pir Nothing + +getHackageTarball + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => PackageIdentifierRevision + -> Maybe TreeKey + -> RIO env HackageTarballResult +getHackageTarball pir mtreeKey = do + let PackageIdentifierRevision name ver _cfi = pir + cabalFile <- resolveCabalFileInfo pir + let rpli = RPLIHackage pir mtreeKey + withCachedTree rpli name ver cabalFile $ do + cabalFileKey <- withStorage $ getBlobKey cabalFile + mpair <- withStorage $ loadHackageTarballInfo name ver + (sha, size) <- + case mpair of + Just pair -> pure pair + Nothing -> do + let exc = NoHackageCryptographicHash $ PackageIdentifier name ver + updated <- updateHackageIndex $ Just $ display exc <> ", updating" + mpair2 <- + case updated of + UpdateOccurred -> withStorage $ loadHackageTarballInfo name ver + NoUpdateOccurred -> pure Nothing + case mpair2 of + Nothing -> throwIO exc + Just pair2 -> pure pair2 + pc <- view pantryConfigL + let urlPrefix = hscDownloadPrefix $ pcHackageSecurity pc + url = + mconcat + [ urlPrefix + , "package/" + , T.pack $ Distribution.Text.display name + , "-" + , T.pack $ Distribution.Text.display ver + , ".tar.gz" + ] + package <- + getArchivePackage + rpli + RawArchive + { raLocation = ALUrl url + , raHash = Just sha + , raSize = Just size + , raSubdir = T.empty -- no subdirs on Hackage + } + RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just ver + , rpmTreeKey = Nothing -- with a revision cabal file will differ giving a different tree + , rpmCabal = Nothing -- cabal file in the tarball may be different! + } + case packageTree package of + TreeMap m -> do + let ft = + case packageCabalEntry package of + PCCabalFile (TreeEntry _ ft') -> ft' + _ -> error "Impossible: Hackage does not support hpack" + cabalEntry = TreeEntry cabalFileKey ft + tree' = TreeMap $ Map.insert (cabalFileName name) cabalEntry m + ident = PackageIdentifier name ver + cabalBS <- + withStorage $ do + let BlobKey sha' _ = cabalFileKey + mcabalBS <- loadBlobBySHA sha' + case mcabalBS of + Nothing -> + error $ + "Invariant violated, cabal file key: " ++ show cabalFileKey + Just bid -> loadBlobById bid + (_warnings, gpd) <- rawParseGPD (Left rpli) cabalBS + let gpdIdent = Cabal.package $ Cabal.packageDescription gpd + when (ident /= gpdIdent) $ + throwIO $ + MismatchedCabalFileForHackage + pir + Mismatch {mismatchExpected = ident, mismatchActual = gpdIdent} + (tid, treeKey') <- + withStorage $ + storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry) + pure + HackageTarballResult + { htrPackage = + Package + { packageTreeKey = treeKey' + , packageTree = tree' + , packageIdent = ident + , packageCabalEntry = PCCabalFile cabalEntry + } + , htrFreshPackageInfo = Just (gpd, tid) + } diff --git a/src/Pantry/Internal.hs b/src/Pantry/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Internal.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Exposed for testing, do not use! +module Pantry.Internal + ( parseTree + , renderTree + , Tree (..) + , TreeEntry (..) + , mkSafeFilePath + , pcHpackExecutable + , normalizeParents + , makeTarRelative + , getGlobalHintsFile + , hpackVersion + , Storage + , initStorage + , withStorage_ + ) where + +import Control.Exception (assert) +import Pantry.Types +import Pantry.SQLite (initStorage) +import Pantry.HPack (hpackVersion) +import qualified Data.Text as T +import Data.Maybe (fromMaybe) + +-- | Like @System.FilePath.normalise@, however: +-- +-- * Only works on relative paths, absolute paths fail +-- +-- * Strips trailing slashes +-- +-- * Only works on forward slashes, even on Windows +-- +-- * Normalizes parent dirs @foo/../@ get stripped +-- +-- * Cannot begin with a parent directory (@../@) +-- +-- * Spelled like an American, sorry +normalizeParents + :: FilePath + -> Either String FilePath +normalizeParents "" = Left "empty file path" +normalizeParents ('/':_) = Left "absolute path" +normalizeParents ('.':'.':'/':_) = Left "absolute path" +normalizeParents fp = do + -- Strip a single trailing, but not multiple + let t0 = T.pack fp + t = fromMaybe t0 $ T.stripSuffix "/" t0 + case T.unsnoc t of + Just (_, '/') -> Left "multiple trailing slashes" + _ -> Right () + + let c1 = T.split (== '/') t + + case reverse c1 of + ".":_ -> Left "last component is a single dot" + _ -> Right () + + let c2 = filter (\x -> not (T.null x || x == ".")) c1 + + let loop [] = [] + loop (_:"..":rest) = loop rest + loop (x:xs) = x : loop xs + + case loop c2 of + [] -> Left "no non-empty components" + c' -> Right $ T.unpack $ T.intercalate "/" c' + +-- | Following tar file rules (Unix file paths only), make the second +-- file relative to the first file. +makeTarRelative + :: FilePath -- ^ base file + -> FilePath -- ^ relative part + -> Either String FilePath +makeTarRelative _ ('/':_) = Left "absolute path found" +makeTarRelative base rel = + case reverse base of + [] -> Left "cannot have empty base" + '/':_ -> Left "base cannot be a directory" + _:rest -> Right $ + case dropWhile (/= '/') rest of + '/':rest' -> reverse rest' ++ '/' : rel + rest' -> assert (null rest') rel diff --git a/src/Pantry/Internal/AesonExtended.hs b/src/Pantry/Internal/AesonExtended.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Internal/AesonExtended.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Extensions to Aeson parsing of objects. This module is intended +-- for internal use by Pantry and Stack only. The intention is to +-- fully remove this module in the future. /DO NOT RELY ON IT/. +module Pantry.Internal.AesonExtended ( + module Export + -- * Extended failure messages + , (.:) + , (.:?) + -- * JSON Parser that emits warnings + , JSONWarning (..) + , WarningParser + , WithJSONWarnings (..) + , withObjectWarnings + , jsonSubWarnings + , jsonSubWarningsT + , jsonSubWarningsTT + , logJSONWarnings + , noJSONWarnings + , tellJSONField + , unWarningParser + , (..:) + , (...:) + , (..:?) + , (...:?) + , (..!=) + ) where + +import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) +import Data.Aeson as Export hiding ((.:), (.:?)) +import qualified Data.Aeson as A +import Data.Aeson.Types hiding ((.:), (.:?)) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import Data.Text (unpack) +import qualified Data.Text as T +import Generics.Deriving.Monoid (mappenddefault, memptydefault) +import RIO +import RIO.PrettyPrint.StylesUpdate (StylesUpdate) + +-- | Extends @.:@ warning to include field name. +(.:) :: FromJSON a => Object -> Text -> Parser a +(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p) +{-# INLINE (.:) #-} + +-- | Extends @.:?@ warning to include field name. +(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) +(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p) +{-# INLINE (.:?) #-} + +-- | 'WarningParser' version of @.:@. +(..:) + :: FromJSON a + => Object -> Text -> WarningParser a +o ..: k = tellJSONField k >> lift (o .: k) + +-- | 'WarningParser' version of @.:?@. +(..:?) + :: FromJSON a + => Object -> Text -> WarningParser (Maybe a) +o ..:? k = tellJSONField k >> lift (o .:? k) + +-- | 'WarningParser' version of @.!=@. +(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a +wp ..!= d = + flip mapWriterT wp $ + \p -> + do a <- fmap snd p + fmap (, a) (fmap fst p .!= d) + +presentCount :: Object -> [Text] -> Int +presentCount o ss = length . filter (\x -> HashMap.member x o) $ ss + +-- | Synonym version of @..:@. +(...:) :: FromJSON a => Object -> [Text] -> WarningParser a +_ ...: [] = fail "failed to find an empty key" +o ...: ss@(key:_) = apply + where pc = presentCount o ss + apply | pc == 0 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "keys " ++ show ss ++ " not present" + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss + +-- | Synonym version of @..:?@. +(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a) +_ ...:? [] = fail "failed to find an empty key" +o ...:? ss@(key:_) = apply + where pc = presentCount o ss + apply | pc == 0 = return Nothing + | pc > 1 = fail $ + "failed to parse field " ++ + show key ++ ": " ++ + "two or more synonym keys " ++ + show ss ++ " present" + | otherwise = asum $ map (o..:) ss + +-- | Tell warning parser about an expected field, so it doesn't warn about it. +tellJSONField :: Text -> WarningParser () +tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) + +-- | 'WarningParser' version of 'withObject'. +withObjectWarnings :: String + -> (Object -> WarningParser a) + -> Value + -> Parser (WithJSONWarnings a) +withObjectWarnings expected f = + withObject expected $ + \obj -> + do (a,w) <- runWriterT (f obj) + let unrecognizedFields = + Set.toList + (Set.difference + (Set.fromList (HashMap.keys obj)) + (wpmExpectedFields w)) + return + (WithJSONWarnings a + (wpmWarnings w ++ + case unrecognizedFields of + [] -> [] + _ -> [JSONUnrecognizedFields expected unrecognizedFields])) + +-- | Convert a 'WarningParser' to a 'Parser'. +unWarningParser :: WarningParser a -> Parser a +unWarningParser wp = do + (a,_) <- runWriterT wp + return a + +-- | Log JSON warnings. +logJSONWarnings + :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) + => FilePath -> [JSONWarning] -> m () +logJSONWarnings fp = + mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w)) + +-- | Handle warnings in a sub-object. +jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a +jsonSubWarnings f = do + WithJSONWarnings result warnings <- f + tell + (mempty + { wpmWarnings = warnings + }) + return result + +-- | Handle warnings in a @Traversable@ of sub-objects. +jsonSubWarningsT + :: Traversable t + => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a) +jsonSubWarningsT f = + mapM (jsonSubWarnings . return) =<< f + +-- | Handle warnings in a @Maybe Traversable@ of sub-objects. +jsonSubWarningsTT + :: (Traversable t, Traversable u) + => WarningParser (u (t (WithJSONWarnings a))) + -> WarningParser (u (t a)) +jsonSubWarningsTT f = + mapM (jsonSubWarningsT . return) =<< f + +-- Parsed JSON value without any warnings +noJSONWarnings :: a -> WithJSONWarnings a +noJSONWarnings v = WithJSONWarnings v [] + +-- | JSON parser that warns about unexpected fields in objects. +type WarningParser a = WriterT WarningParserMonoid Parser a + +-- | Monoid used by 'WarningParser' to track expected fields and warnings. +data WarningParserMonoid = WarningParserMonoid + { wpmExpectedFields :: !(Set Text) + , wpmWarnings :: [JSONWarning] + } deriving Generic +instance Semigroup WarningParserMonoid where + (<>) = mappenddefault +instance Monoid WarningParserMonoid where + mempty = memptydefault + mappend = (<>) +instance IsString WarningParserMonoid where + fromString s = mempty { wpmWarnings = [fromString s] } + +-- Parsed JSON value with its warnings +data WithJSONWarnings a = WithJSONWarnings a [JSONWarning] + deriving (Eq, Generic, Show) +instance Functor WithJSONWarnings where + fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w +instance Monoid a => Semigroup (WithJSONWarnings a) where + (<>) = mappenddefault +instance Monoid a => Monoid (WithJSONWarnings a) where + mempty = memptydefault + mappend = (<>) + +-- | Warning output from 'WarningParser'. +data JSONWarning = JSONUnrecognizedFields String [Text] + | JSONGeneralWarning !Text + deriving Eq +instance Show JSONWarning where + show = T.unpack . utf8BuilderToText . display +instance Display JSONWarning where + display (JSONUnrecognizedFields obj [field]) = + "Unrecognized field in " <> fromString obj <> ": " <> display field + display (JSONUnrecognizedFields obj fields) = + "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields) + display (JSONGeneralWarning t) = display t + +instance IsString JSONWarning where + fromString = JSONGeneralWarning . T.pack + +instance FromJSON (WithJSONWarnings StylesUpdate) where + parseJSON v = noJSONWarnings <$> parseJSON v diff --git a/src/Pantry/Internal/Companion.hs b/src/Pantry/Internal/Companion.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Internal/Companion.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | Companion threads, such as for printing messages saying we're +-- still busy. Ultimately this could be put into its own package. This +-- is a non-standard API for use by Pantry and Stack, please /DO NOT +-- DEPEND ON IT/. +module Pantry.Internal.Companion + ( withCompanion + , onCompanionDone + , Companion + , Delay + , StopCompanion + ) where + +import RIO + +-- | A companion thread which can perform arbitrary actions as well as delay +type Companion m = Delay -> m () + +-- | Delay the given number of microseconds. If 'StopCompanion' is +-- triggered before the timer completes, a 'CompanionDone' exception +-- will be thrown (which is caught internally by 'withCompanion'). +type Delay = forall mio. MonadIO mio => Int -> mio () + +-- | Tell the 'Companion' to stop. The next time 'Delay' is +-- called, or if a 'Delay' is currently blocking, the 'Companion' thread +-- will exit with a 'CompanionDone' exception. +type StopCompanion m = m () + +-- | When a delay was interrupted because we're told to stop, perform +-- this action. +onCompanionDone + :: MonadUnliftIO m + => m () -- ^ the delay + -> m () -- ^ action to perform + -> m () +onCompanionDone theDelay theAction = + theDelay `withException` \CompanionDone -> theAction + +-- | Internal exception used by 'withCompanion' to allow short-circuiting +-- of the 'Companion'. Should not be used outside of this module. +data CompanionDone = CompanionDone + deriving (Show, Typeable) +instance Exception CompanionDone + +-- | Keep running the 'Companion' action until either the inner action +-- completes or calls the 'StopCompanion' action. This can be used to +-- give the user status information while running a long running +-- operations. +withCompanion + :: forall m a. MonadUnliftIO m + => Companion m + -> (StopCompanion m -> m a) + -> m a +withCompanion companion inner = do + -- Variable to indicate 'Delay'ing should result in a 'CompanionDone' + -- exception. + shouldStopVar <- newTVarIO False + let -- Relatively simple: set shouldStopVar to True + stopCompanion = atomically $ writeTVar shouldStopVar True + + delay :: Delay + delay usec = do + -- Register a delay with the runtime system + delayDoneVar <- registerDelay usec + join $ atomically $ + -- Delay has triggered, keep going + (pure () <$ (readTVar delayDoneVar >>= checkSTM)) <|> + -- Time to stop the companion, throw a 'CompanionDone' exception immediately + (throwIO CompanionDone <$ (readTVar shouldStopVar >>= checkSTM)) + + -- Run the 'Companion' and inner action together + runConcurrently $ + -- Ignore a 'CompanionDone' exception from the companion, that's expected behavior + Concurrently (companion delay `catch` \CompanionDone -> pure ()) *> + -- Run the inner action, giving it the 'StopCompanion' action, and + -- ensuring it is called regardless of exceptions. + Concurrently (inner stopCompanion `finally` stopCompanion) diff --git a/src/Pantry/Internal/Stackage.hs b/src/Pantry/Internal/Stackage.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Internal/Stackage.hs @@ -0,0 +1,51 @@ +-- | All types and functions exported from this module are for advanced usage +-- only. They are needed for stackage-server integration with pantry. +module Pantry.Internal.Stackage + ( module X + ) where + +import Pantry.Hackage as X + ( forceUpdateHackageIndex + , getHackageTarball + , HackageTarballResult(..) + ) +import Pantry.Storage as X + ( BlobId + , EntityField(..) + , HackageCabalId + , ModuleNameId + , PackageName + , PackageNameId + , Tree(..) + , TreeEntry(..) + , TreeEntryId + , TreeId + , Unique(..) + , Version + , VersionId + , getBlobKey + , getPackageNameById + , getPackageNameId + , getTreeForKey + , getVersionId + , loadBlobById + , migrateAll + , treeCabal + , Key(unBlobKey) + ) +import Pantry.Types as X + ( ModuleNameP(..) + , PackageNameP(..) + , PantryConfig(..) + , SafeFilePath + , Storage(..) + , VersionP(..) + , mkSafeFilePath + , packageNameString + , packageTreeKey + , parsePackageName + , parseVersion + , parseVersionThrowing + , unSafeFilePath + , versionString + ) diff --git a/src/Pantry/Internal/StaticBytes.hs b/src/Pantry/Internal/StaticBytes.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Internal/StaticBytes.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | This is an unstable API, exposed only for testing. Relying on +-- this may break your code! Caveat emptor. +-- +-- This module can (and perhaps should) be separate into its own +-- package, it's generally useful. +module Pantry.Internal.StaticBytes + ( Bytes8 + , Bytes16 + , Bytes32 + , Bytes64 + , Bytes128 + , DynamicBytes + , StaticBytes + , StaticBytesException (..) + , toStaticExact + , toStaticPad + , toStaticTruncate + , toStaticPadTruncate + , fromStatic + ) where + +import RIO hiding (words) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Base as VU +import qualified Data.Vector.Storable as VS +import System.IO.Unsafe (unsafePerformIO) +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable +import Data.Bits +import qualified Data.Primitive.ByteArray as BA +import Data.ByteArray + +newtype Bytes8 = Bytes8 Word64 + deriving (Eq, Ord, Generic, NFData, Hashable, Data) +instance Show Bytes8 where + show (Bytes8 w) = show (fromWordsD 8 [w] :: B.ByteString) +data Bytes16 = Bytes16 !Bytes8 !Bytes8 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes32 = Bytes32 !Bytes16 !Bytes16 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes64 = Bytes64 !Bytes32 !Bytes32 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) +data Bytes128 = Bytes128 !Bytes64 !Bytes64 + deriving (Show, Eq, Ord, Generic, NFData, Hashable, Data) + +data StaticBytesException + = NotEnoughBytes + | TooManyBytes + deriving (Show, Eq, Typeable) +instance Exception StaticBytesException + +-- All lengths below are given in bytes + +class DynamicBytes dbytes where + lengthD :: dbytes -> Int + -- | Yeah, it looks terrible to use a list here, but fusion should + -- kick in + withPeekD :: dbytes -> ((Int -> IO Word64) -> IO a) -> IO a + -- | May throw a runtime exception if invariants are violated! + fromWordsD :: Int -> [Word64] -> dbytes + +fromWordsForeign + :: (ForeignPtr a -> Int -> b) + -> Int + -> [Word64] + -> b +fromWordsForeign wrapper len words0 = unsafePerformIO $ do + fptr <- B.mallocByteString len + withForeignPtr fptr $ \ptr -> do + let loop _ [] = return () + loop off (w:ws) = do + pokeElemOff (castPtr ptr) off w + loop (off + 1) ws + loop 0 words0 + return $ wrapper fptr len + +withPeekForeign + :: (ForeignPtr a, Int, Int) + -> ((Int -> IO Word64) -> IO b) + -> IO b +withPeekForeign (fptr, off, len) inner = + withForeignPtr fptr $ \ptr -> do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + w8 :: Word8 <- peekByteOff ptr (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = peekByteOff ptr (off + off') + inner f + +instance DynamicBytes B.ByteString where + lengthD = B.length + fromWordsD = fromWordsForeign (\fptr len -> B.fromForeignPtr fptr 0 len) + withPeekD = withPeekForeign . B.toForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VS.Vector word8) where + lengthD = VS.length + fromWordsD = fromWordsForeign VS.unsafeFromForeignPtr0 + withPeekD = withPeekForeign . VS.unsafeToForeignPtr + +instance word8 ~ Word8 => DynamicBytes (VP.Vector word8) where + lengthD = VP.length + fromWordsD len words0 = unsafePerformIO $ do + ba <- BA.newByteArray len + let loop _ [] = + VP.Vector 0 len <$> BA.unsafeFreezeByteArray ba + loop i (w:ws) = do + BA.writeByteArray ba i w + loop (i + 1) ws + loop 0 words0 + withPeekD (VP.Vector off len ba) inner = do + let f off' + | off' >= len = return 0 + | off' + 8 > len = do + let loop w64 i + | off' + i >= len = return w64 + | otherwise = do + let w8 :: Word8 = BA.indexByteArray ba (off + off' + i) + let w64' = shiftL (fromIntegral w8) (i * 8) .|. w64 + loop w64' (i + 1) + loop 0 0 + | otherwise = return $ BA.indexByteArray ba (off + (off' `div` 8)) + inner f + +instance word8 ~ Word8 => DynamicBytes (VU.Vector word8) where + lengthD = VU.length + fromWordsD len words = VU.V_Word8 (fromWordsD len words) + withPeekD (VU.V_Word8 v) = withPeekD v + +class StaticBytes sbytes where + lengthS :: proxy sbytes -> Int -- use type level literals instead? + -- difference list + toWordsS :: sbytes -> [Word64] -> [Word64] + usePeekS :: Int -> (Int -> IO Word64) -> IO sbytes + +instance StaticBytes Bytes8 where + lengthS _ = 8 + toWordsS (Bytes8 w) = (w:) + usePeekS off f = Bytes8 <$> f off + +instance StaticBytes Bytes16 where + lengthS _ = 16 + toWordsS (Bytes16 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes16 <$> usePeekS off f <*> usePeekS (off + 8) f + +instance StaticBytes Bytes32 where + lengthS _ = 32 + toWordsS (Bytes32 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes32 <$> usePeekS off f <*> usePeekS (off + 16) f + +instance StaticBytes Bytes64 where + lengthS _ = 64 + toWordsS (Bytes64 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes64 <$> usePeekS off f <*> usePeekS (off + 32) f + +instance StaticBytes Bytes128 where + lengthS _ = 128 + toWordsS (Bytes128 b1 b2) = toWordsS b1 . toWordsS b2 + usePeekS off f = Bytes128 <$> usePeekS off f <*> usePeekS (off + 64) f + +instance ByteArrayAccess Bytes8 where + length _ = 8 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes16 where + length _ = 16 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes32 where + length _ = 32 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes64 where + length _ = 64 + withByteArray = withByteArrayS +instance ByteArrayAccess Bytes128 where + length _ = 128 + withByteArray = withByteArrayS + +withByteArrayS :: StaticBytes sbytes => sbytes -> (Ptr p -> IO a) -> IO a +withByteArrayS sbytes = withByteArray (fromStatic sbytes :: ByteString) + +toStaticExact + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticExact dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + GT -> Left TooManyBytes + EQ -> Right (toStaticPadTruncate dbytes) + +toStaticPad + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticPad dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + GT -> Left TooManyBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticTruncate + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> Either StaticBytesException sbytes +toStaticTruncate dbytes = + case compare (lengthD dbytes) (lengthS (Nothing :: Maybe sbytes)) of + LT -> Left NotEnoughBytes + _ -> Right (toStaticPadTruncate dbytes) + +toStaticPadTruncate + :: (DynamicBytes dbytes, StaticBytes sbytes) + => dbytes + -> sbytes +toStaticPadTruncate dbytes = unsafePerformIO (withPeekD dbytes (usePeekS 0)) + +fromStatic + :: forall dbytes sbytes. + (DynamicBytes dbytes, StaticBytes sbytes) + => sbytes + -> dbytes +fromStatic = fromWordsD (lengthS (Nothing :: Maybe sbytes)) . ($ []) . toWordsS diff --git a/src/Pantry/Repo.hs b/src/Pantry/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Repo.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pantry.Repo + ( fetchReposRaw + , fetchRepos + , getRepo + , getRepoKey + , createRepoArchive + , withRepoArchive + , withRepo + ) where + +import Pantry.Types +import Pantry.Archive +import Pantry.Storage +import RIO +import Path.IO (resolveFile') +import RIO.FilePath (()) +import RIO.Directory (doesDirectoryExist) +import qualified RIO.Map as Map +import RIO.Process +import Database.Persist (Entity (..)) +import qualified RIO.Text as T +import System.Console.ANSI (hSupportsANSIWithoutEmulation) +import System.IsWindows (osIsWindows) + +fetchReposRaw + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Repo, RawPackageMetadata)] + -> RIO env () +fetchReposRaw pairs = for_ pairs $ uncurry getRepo + +fetchRepos + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(Repo, PackageMetadata)] + -> RIO env () +fetchRepos pairs = do + -- TODO be more efficient, group together shared archives + fetchReposRaw $ map (second toRawPM) pairs + +getRepoKey + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env TreeKey +getRepoKey repo rpm = packageTreeKey <$> getRepo repo rpm -- potential optimization + +getRepo + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env Package +getRepo repo pm = + withCache $ getRepo' repo pm + where + withCache + :: RIO env Package + -> RIO env Package + withCache inner = do + mtid <- withStorage (loadRepoCache repo (repoSubdir repo)) + case mtid of + Just tid -> withStorage $ loadPackageById (RPLIRepo repo pm) tid + Nothing -> do + package <- inner + withStorage $ do + ment <- getTreeForKey $ packageTreeKey package + case ment of + Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package) + Just (Entity tid _) -> storeRepoCache repo (repoSubdir repo) tid + pure package + +getRepo' + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Repo + -> RawPackageMetadata + -> RIO env Package +getRepo' repo rpm = do + withRepoArchive repo $ \tarball -> do + abs' <- resolveFile' tarball + getArchivePackage + (RPLIRepo repo rpm) + RawArchive + { raLocation = ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ T.pack tarball + , resolvedAbsolute = abs' + } + , raHash = Nothing + , raSize = Nothing + , raSubdir = repoSubdir repo + } + rpm + +-- | Fetch a repository and create a (temporary) tar archive from it. Pass the +-- path of the generated tarball to the given action. +withRepoArchive + :: forall env a. (HasLogFunc env, HasProcessContext env) + => Repo + -> (FilePath -> RIO env a) + -> RIO env a +withRepoArchive repo action = + withSystemTempDirectory "with-repo-archive" $ \tmpdir -> do + let tarball = tmpdir "foo.tar" + createRepoArchive repo tarball + action tarball + +-- | Run a git command, setting appropriate environment variable settings. See +-- . +runGitCommand + :: (HasLogFunc env, HasProcessContext env) + => [String] -- ^ args + -> RIO env () +runGitCommand args = + withModifyEnvVars go $ + void $ proc "git" args readProcess_ + where + go = Map.delete "GIT_DIR" + . Map.delete "GIT_CEILING_DIRECTORIES" + . Map.delete "GIT_WORK_TREE" + . Map.delete "GIT_INDEX_FILE" + . Map.delete "GIT_OBJECT_DIRECTORY" -- possible optimization: set this to something Pantry controls + . Map.delete "GIT_ALTERNATE_OBJECT_DIRECTORIES" + +-- | Run an hg command +runHgCommand + :: (HasLogFunc env, HasProcessContext env) + => [String] -- ^ args + -> RIO env () +runHgCommand args = void $ proc "hg" args readProcess_ + +-- | Create a tarball containing files from a repository +createRepoArchive + :: forall env. (HasLogFunc env, HasProcessContext env) + => Repo + -> FilePath -- ^ Output tar archive filename + -> RIO env () +createRepoArchive repo tarball = do + withRepo repo $ case repoType repo of + RepoGit -> do + runGitCommand ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"] + -- also include submodules files: use `git submodule foreach` to + -- execute `git archive` in each submodule and to append the + -- generated archive to the main one with `tar -A` + runGitCommand + [ "submodule", "foreach", "--recursive" + , "git -c core.autocrlf=false archive --prefix=$displaypath/ -o bar.tar HEAD" + <> " && if [ -f bar.tar ]; then tar --force-local -Af " <> tarball <> " bar.tar ; fi" + ] + RepoHg -> runHgCommand ["archive", tarball, "-X", ".hg_archival.txt"] + + +-- | Clone the repository and execute the action with the working +-- directory set to the repository root. +-- +-- @since 0.1.0.0 +withRepo + :: forall env a. (HasLogFunc env, HasProcessContext env) + => Repo + -> RIO env a + -> RIO env a +withRepo repo@(Repo url commit repoType' _subdir) action = + withSystemTempDirectory "with-repo" $ + \tmpdir -> withWorkingDir tmpdir $ do + let suffix = "cloned" + dir = tmpdir suffix + + let (runCommand, resetArgs, submoduleArgs) = + case repoType' of + RepoGit -> + ( runGitCommand + , ["reset", "--hard", T.unpack commit] + , Just ["submodule", "update", "--init", "--recursive"] + ) + RepoHg -> + ( runHgCommand + , ["update", "-C", T.unpack commit] + , Nothing + ) + + logInfo $ "Cloning " <> display commit <> " from " <> display url + runCommand ("clone" : [T.unpack url, suffix]) + -- On Windows 10, an upstream issue with the `git clone` command means that + -- command clears, but does not then restore, the + -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The + -- folowing hack re-enables the lost ANSI-capability. + when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout + created <- doesDirectoryExist dir + unless created $ throwIO $ FailedToCloneRepo repo + + withWorkingDir dir $ do + runCommand resetArgs + traverse_ runCommand submoduleArgs + -- On Windows 10, an upstream issue with the `git submodule` command means + -- that command clears, but does not then restore, the + -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The + -- folowing hack re-enables the lost ANSI-capability. + when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout + action diff --git a/src/Pantry/SHA256.hs b/src/Pantry/SHA256.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/SHA256.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Provides a data type ('SHA256') for efficient memory +-- representation of a sha-256 hash value, together with helper +-- functions for converting to and from that value. This module is +-- intended to be imported qualified as @SHA256@. +-- +-- Some nomenclature: +-- +-- * Hashing calculates a new hash value from some input. @from@ takes a value that representats an existing hash. +-- +-- * Raw means a raw binary representation of the hash value, without any hex encoding. +-- +-- * Text always uses lower case hex encoding +-- +-- @since 0.1.0.0 +module Pantry.SHA256 + ( -- * Types + SHA256 + , SHA256Exception (..) + -- * Hashing + , hashFile + , hashBytes + , hashLazyBytes + , sinkHash + -- * Convert from a hash representation + , fromHexText + , fromHexBytes + , fromDigest + , fromRaw + -- * Convert to a hash representation + , toHexText + , toHexBytes + , toRaw + ) where + +import RIO +import Data.Aeson +import Database.Persist.Sql +import Pantry.Internal.StaticBytes +import Conduit +import qualified RIO.Text as T + +import qualified Crypto.Hash.Conduit as Hash (hashFile, sinkHash) +import qualified Crypto.Hash as Hash (hash, hashlazy, Digest, SHA256) +import qualified Data.ByteArray +import qualified Data.ByteArray.Encoding as Mem + +-- | A SHA256 hash, stored in a static size for more efficient +-- memory representation. +-- +-- @since 0.1.0.0 +newtype SHA256 = SHA256 Bytes32 + deriving (Generic, Eq, NFData, Data, Typeable, Ord, Hashable) + +-- | Exceptions which can occur in this module +-- +-- @since 0.1.0.0 +data SHA256Exception + = InvalidByteCount !ByteString !StaticBytesException + | InvalidHexBytes !ByteString !Text + deriving (Typeable) + +-- | Generate a 'SHA256' value by hashing the contents of a file. +-- +-- @since 0.1.0.0 +hashFile :: MonadIO m => FilePath -> m SHA256 +hashFile fp = fromDigest <$> Hash.hashFile fp + +-- | Generate a 'SHA256' value by hashing a @ByteString@. +-- +-- @since 0.1.0.0 +hashBytes :: ByteString -> SHA256 +hashBytes = fromDigest . Hash.hash + +-- | Generate a 'SHA256' value by hashing a lazy @ByteString@. +-- +-- @since 0.1.0.0 +hashLazyBytes :: LByteString -> SHA256 +hashLazyBytes = fromDigest . Hash.hashlazy + +-- | Generate a 'SHA256' value by hashing the contents of a stream. +-- +-- @since 0.1.0.0 +sinkHash :: Monad m => ConduitT ByteString o m SHA256 +sinkHash = fromDigest <$> Hash.sinkHash + +-- | Convert a base16-encoded 'Text' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexText :: Text -> Either SHA256Exception SHA256 +fromHexText = fromHexBytes . encodeUtf8 + +-- | Convert a base16-encoded 'ByteString' value containing a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromHexBytes :: ByteString -> Either SHA256Exception SHA256 +fromHexBytes hexBS = do + mapLeft (InvalidHexBytes hexBS . T.pack) (Mem.convertFromBase Mem.Base16 hexBS) >>= fromRaw + +-- | Convert a 'Hash.Digest' into a 'SHA256' +-- +-- @since 0.1.0.0 +fromDigest :: Hash.Digest Hash.SHA256 -> SHA256 +fromDigest digest = + case toStaticExact (Data.ByteArray.convert digest :: ByteString) of + Left e -> error $ "Impossible failure in fromDigest: " ++ show (digest, e) + Right x -> SHA256 x + +-- | Convert a raw representation of a hash into a 'SHA256'. +-- +-- @since 0.1.0.0 +fromRaw :: ByteString -> Either SHA256Exception SHA256 +fromRaw bs = either (Left . InvalidByteCount bs) (Right . SHA256) (toStaticExact bs) + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexText :: SHA256 -> Text +toHexText ss = + case decodeUtf8' $ toHexBytes ss of + Left e -> error $ "Impossible failure in staticSHA256ToText: " ++ show (ss, e) + Right t -> t + +-- | Convert a 'SHA256' into a base16-encoded SHA256 hash. +-- +-- @since 0.1.0.0 +toHexBytes :: SHA256 -> ByteString +toHexBytes (SHA256 x) = Mem.convertToBase Mem.Base16 x + +-- | Convert a 'SHA256' into a raw binary representation. +-- +-- @since 0.1.0.0 +toRaw :: SHA256 -> ByteString +toRaw (SHA256 x) = Data.ByteArray.convert x + +-- Instances + +instance Show SHA256 where + show s = "SHA256 " ++ show (toHexText s) + +instance PersistField SHA256 where + toPersistValue = PersistByteString . toRaw + fromPersistValue (PersistByteString bs) = + case toStaticExact bs of + Left e -> Left $ tshow e + Right ss -> pure $ SHA256 ss + fromPersistValue x = Left $ "Unexpected value: " <> tshow x + +instance PersistFieldSql SHA256 where + sqlType _ = SqlBlob + +instance Display SHA256 where + display = displayBytesUtf8 . toHexBytes + +instance ToJSON SHA256 where + toJSON = toJSON . toHexText +instance FromJSON SHA256 where + parseJSON = withText "SHA256" $ \t -> + case fromHexText t of + Right x -> pure x + Left e -> fail $ concat + [ "Invalid SHA256 " + , show t + , ": " + , show e + ] + +instance Exception SHA256Exception +instance Show SHA256Exception where + show = T.unpack . utf8BuilderToText . display +instance Display SHA256Exception where + display (InvalidByteCount bs sbe) = + "Invalid byte count creating a SHA256 from " <> + displayShow bs <> + ": " <> + displayShow sbe + display (InvalidHexBytes bs t) = + "Invalid hex bytes creating a SHA256: " <> + displayShow bs <> + ": " <> + display t diff --git a/src/Pantry/SQLite.hs b/src/Pantry/SQLite.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/SQLite.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Pantry.SQLite + ( Storage (..) + , initStorage + ) where + +import RIO hiding (FilePath) +import Database.Persist.Sqlite +import RIO.Orphans () +import Path (Path, Abs, File, toFilePath, parent) +import Path.IO (ensureDir) +import Pantry.Types (PantryException (MigrationFailure), Storage (..)) +import System.FileLock (withFileLock, withTryFileLock, SharedExclusive (..)) +import Pantry.Internal.Companion + +initStorage + :: HasLogFunc env + => Text + -> Migration + -> Path Abs File -- ^ storage file + -> (Storage -> RIO env a) + -> RIO env a +initStorage description migration fp inner = do + ensureDir $ parent fp + + migrates <- withWriteLock (display description) fp $ wrapMigrationFailure $ + withSqliteConnInfo (sqinfo True) $ runSqlConn $ + runMigrationSilent migration + forM_ migrates $ \mig -> logDebug $ "Migration executed: " <> display mig + + -- Make a single connection to the SQLite database and wrap it in an MVar for + -- the entire execution context. Previously we used a resource pool of size + -- 1, but (1) there's no advantage to that, and (2) it had a _very_ weird + -- interaction with Docker on OS X where when resource-pool's reaper would + -- trigger, it would somehow cause the Stack process inside the container to + -- die with a SIGBUS. Definitely an interesting thing worth following up + -- on... + withSqliteConnInfo (sqinfo False) $ \conn0 -> do + connVar <- newMVar conn0 + inner $ Storage + -- NOTE: Currently, we take a write lock on every action. This is + -- a bit heavyweight, but it avoids the SQLITE_BUSY errors + -- reported in + -- + -- completely. We can investigate more elegant solutions in the + -- future, such as separate read and write actions or introducing + -- smarter retry logic. + { withStorage_ = \action -> withMVar connVar $ \conn -> + withWriteLock (display description) fp $ + runSqlConn action conn + , withWriteLock_ = id + } + where + wrapMigrationFailure = handleAny (throwIO . MigrationFailure description fp) + + sqinfo isMigration + = set extraPragmas ["PRAGMA busy_timeout=2000;"] + + -- When doing a migration, we want to disable foreign key + -- checking, since the order in which tables are created by + -- the migration scripts may not respect foreign keys. The + -- rest of the time: enforce those foreign keys. + $ set fkEnabled (not isMigration) + + $ mkSqliteConnectionInfo (fromString $ toFilePath fp) + +-- | Ensure that only one process is trying to write to the database +-- at a time. See +-- https://github.com/commercialhaskell/stack/issues/4471 and comments +-- above. +withWriteLock + :: HasLogFunc env + => Utf8Builder -- ^ database description, for lock messages + -> Path Abs File -- ^ SQLite database file + -> RIO env a + -> RIO env a +withWriteLock desc dbFile inner = do + let lockFile = toFilePath dbFile ++ ".pantry-write-lock" + withRunInIO $ \run -> do + mres <- withTryFileLock lockFile Exclusive $ const $ run inner + case mres of + Just res -> pure res + Nothing -> do + let complainer :: Companion IO + complainer delay = run $ do + -- Wait five seconds before giving the first message to + -- avoid spamming the user for uninteresting file locks + delay $ 5 * 1000 * 1000 -- 5 seconds + logInfo $ "Unable to get a write lock on the " <> desc <> " database, waiting..." + + -- Now loop printing a message every 1 minute + forever $ do + delay (60 * 1000 * 1000) -- 1 minute + `onCompanionDone` logInfo ("Acquired the " <> desc <> " database write lock") + logWarn ("Still waiting on the " <> desc <> " database write lock...") + withCompanion complainer $ \stopComplaining -> + withFileLock lockFile Exclusive $ const $ do + stopComplaining + run inner diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Storage.hs @@ -0,0 +1,1101 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +module Pantry.Storage + ( SqlBackend + , initStorage + , withStorage + , migrateAll + , storeBlob + , loadBlob + , loadBlobById + , loadBlobBySHA + , getBlobKey + , loadURLBlob + , storeURLBlob + , clearHackageRevisions + , storeHackageRevision + , loadHackagePackageVersions + , loadHackagePackageVersion + , loadLatestCacheUpdate + , storeCacheUpdate + , storeHackageTarballInfo + , loadHackageTarballInfo + , getHPackBlobKeyById + , storeTree + , loadTree + , storeHPack + , loadPackageById + , getPackageNameById + , getPackageNameId + , getVersionId + , getTreeForKey + , storeHackageTree + , loadHackageTree + , loadHackageTreeKey + , storeArchiveCache + , loadArchiveCache + , storeRepoCache + , loadRepoCache + , storePreferredVersion + , loadPreferredVersion + , sinkHackagePackageNames + , loadCabalBlobKey + , hpackToCabal + , countHackageCabals + , getSnapshotCacheByHash + , getSnapshotCacheId + , storeSnapshotModuleCache + , loadExposedModulePackages + , PackageNameId + , PackageName + , VersionId + , ModuleNameId + , Version + , Unique(..) + , EntityField(..) + -- avoid warnings + , BlobId + , Key(unBlobKey) + , HackageCabalId + , HackageCabal(..) + , HackageTarballId + , CacheUpdateId + , FilePathId + , Tree(..) + , TreeId + , TreeEntry(..) + , TreeEntryId + , ArchiveCacheId + , RepoCacheId + , PreferredVersionsId + , UrlBlobId + , SnapshotCacheId + , PackageExposedModuleId + ) where + +import RIO hiding (FilePath) +import RIO.Process +import qualified RIO.ByteString as B +import qualified Pantry.Types as P +import qualified RIO.List as List +import qualified RIO.FilePath as FilePath +import RIO.FilePath ((), takeDirectory) +import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.TH +import RIO.Orphans () +import qualified Pantry.SHA256 as SHA256 +import qualified RIO.Map as Map +import qualified RIO.Text as T +import RIO.Time (UTCTime, getCurrentTime) +import Path (Path, Abs, File, Dir, toFilePath, filename, parseAbsDir, fromAbsFile, fromRelFile) +import Path.IO (listDir, createTempDir, getTempDir, removeDirRecur) +import Pantry.HPack (hpackVersion, hpack) +import Conduit +import Data.Acquire (with) +import Pantry.Types (PackageNameP (..), VersionP (..), SHA256, FileSize (..), FileType (..), HasPantryConfig, BlobKey, Repo (..), TreeKey, SafeFilePath, Revision (..), Package (..), SnapshotCacheHash (..)) +import qualified Pantry.SQLite as SQLite + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +-- Raw blobs +Blob + sha SHA256 + size FileSize + contents ByteString + UniqueBlobSha sha +-- Previously downloaded blobs from given URLs. +-- May change over time, so we keep a time column too. +UrlBlob sql=url_blob + url Text + blob BlobId + time UTCTime + UniqueUrlTime url time + +-- For normalization, and avoiding storing strings in a bunch of +-- tables. +PackageName + name P.PackageNameP + UniquePackageName name +Version + version P.VersionP + UniqueVersion version +FilePath + path P.SafeFilePath + UniqueSfp path + +-- Secure download information for a package on Hackage. This does not +-- contain revision information, since sdist tarballs are (blessedly) +-- unmodified on Hackage. +HackageTarball + name PackageNameId + version VersionId + sha SHA256 + size FileSize + UniqueHackageTarball name version + +-- An individual cabal file from Hackage, representing a specific +-- revision. +HackageCabal + name PackageNameId + version VersionId + revision P.Revision + cabal BlobId + + -- If available: the full tree containing the HackageTarball + -- contents with the cabal file modified. + tree TreeId Maybe + UniqueHackage name version revision + +-- Any preferred-version information from Hackage +PreferredVersions + name PackageNameId + preferred Text + UniquePreferred name + +-- Last time we downloaded a 01-index.tar file from Hackage and +-- updated the three previous tables. +CacheUpdate + -- When did we do the update? + time UTCTime + + -- How big was the file when we updated, ignoring the last two + -- all-null 512-byte blocks. + size FileSize + + -- SHA256 of the first 'size' bytes of the file + sha SHA256 + +-- A tree containing a Haskell package. See associated TreeEntry +-- table. +Tree + key BlobId + + -- If the treeCabal field is Nothing, it means the Haskell package + -- doesn't have a corresponding cabal file for it. This may be the case + -- for haskell package referenced by git repository with only a hpack file. + cabal BlobId Maybe + cabalType FileType + name PackageNameId + version VersionId + UniqueTree key + +HPack + tree TreeId + + -- hpack version used for generating this cabal file + version VersionId + + -- Generated cabal file for the given tree and hpack version + cabalBlob BlobId + cabalPath FilePathId + + UniqueHPack tree version + +-- An individual file within a Tree. +TreeEntry + tree TreeId + path FilePathId + blob BlobId + type FileType + +-- Like UrlBlob, but stores the contents as a Tree. +ArchiveCache + time UTCTime + url Text + subdir Text + sha SHA256 + size FileSize + tree TreeId + +-- Like ArchiveCache, but for a Repo. +RepoCache + time UTCTime + url Text + type P.RepoType + commit Text + subdir Text + tree TreeId + +-- Identified by sha of all immutable packages contained in a snapshot +-- and GHC version used +SnapshotCache + sha SHA256 + UniqueSnapshotCache sha + +PackageExposedModule + snapshotCache SnapshotCacheId + module ModuleNameId + package PackageNameId + +ModuleName + name P.ModuleNameP + UniqueModule name +|] + +initStorage + :: HasLogFunc env + => Path Abs File -- ^ storage file + -> (P.Storage -> RIO env a) + -> RIO env a +initStorage = + SQLite.initStorage "Pantry" migrateAll + +withStorage + :: (HasPantryConfig env, HasLogFunc env) + => ReaderT SqlBackend (RIO env) a + -> RIO env a +withStorage action = + flip SQLite.withStorage_ action =<< view (P.pantryConfigL.to P.pcStorage) + +-- | This is a helper type to distinguish db queries between different rdbms backends. The important +-- part is that the affects described in this data type should be semantically equivalent between +-- the supported engines. +data RdbmsActions env a = RdbmsActions + { raSqlite :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to SQLite + , raPostgres :: !(ReaderT SqlBackend (RIO env) a) + -- ^ A query that is specific to PostgreSQL + } + +-- | This function provides a way to create queries supported by multiple sql backends. +rdbmsAwareQuery + :: RdbmsActions env a + -> ReaderT SqlBackend (RIO env) a +rdbmsAwareQuery RdbmsActions {raSqlite, raPostgres} = do + rdbms <- connRDBMS <$> ask + case rdbms of + "postgresql" -> raPostgres + "sqlite" -> raSqlite + _ -> error $ "rdbmsAwareQuery: unsupported rdbms '" ++ T.unpack rdbms ++ "'" + + +getPackageNameById + :: PackageNameId + -> ReaderT SqlBackend (RIO env) (Maybe P.PackageName) +getPackageNameById = fmap (unPackageNameP . packageNameName <$>) . get + + +getPackageNameId + :: P.PackageName + -> ReaderT SqlBackend (RIO env) PackageNameId +getPackageNameId = fmap (either entityKey id) . insertBy . PackageName . PackageNameP + +getVersionId + :: P.Version + -> ReaderT SqlBackend (RIO env) VersionId +getVersionId = fmap (either entityKey id) . insertBy . Version . VersionP + +storeBlob + :: ByteString + -> ReaderT SqlBackend (RIO env) (BlobId, BlobKey) +storeBlob bs = do + let sha = SHA256.hashBytes bs + size = FileSize $ fromIntegral $ B.length bs + keys <- selectKeysList [BlobSha ==. sha] [] + key <- + case keys of + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = + insert Blob {blobSha = sha, blobSize = size, blobContents = bs} + , raPostgres = + do rawExecute + "INSERT INTO blob(sha, size, contents) VALUES (?, ?, ?) ON CONFLICT DO NOTHING" + [ toPersistValue sha + , toPersistValue size + , toPersistValue bs + ] + rawSql + "SELECT blob.id FROM blob WHERE blob.sha = ?" + [toPersistValue sha] >>= \case + [Single key] -> pure key + _ -> + error + "soreBlob: there was a critical problem storing a blob." + } + key:rest -> assert (null rest) (pure key) + pure (key, P.BlobKey sha size) + +loadBlob :: + HasLogFunc env + => BlobKey + -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadBlob (P.BlobKey sha size) = do + ment <- getBy $ UniqueBlobSha sha + case ment of + Nothing -> pure Nothing + Just (Entity _ bt) + | blobSize bt == size -> pure $ Just $ blobContents bt + | otherwise -> + Nothing <$ lift (logWarn $ + "Mismatched blob size detected for SHA " <> display sha <> + ". Expected size: " <> display size <> + ". Actual size: " <> display (blobSize bt)) + +loadBlobBySHA :: SHA256 -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +loadBlobBySHA sha = listToMaybe <$> selectKeysList [BlobSha ==. sha] [] + +loadBlobById :: BlobId -> ReaderT SqlBackend (RIO env) ByteString +loadBlobById bid = do + mbt <- get bid + case mbt of + Nothing -> error "loadBlobById: ID doesn't exist in database" + Just bt -> pure $ blobContents bt + +getBlobKey :: BlobId -> ReaderT SqlBackend (RIO env) BlobKey +getBlobKey bid = do + res <- rawSql "SELECT sha, size FROM blob WHERE id=?" [toPersistValue bid] + case res of + [] -> error $ "getBlobKey failed due to missing ID: " ++ show bid + [(Single sha, Single size)] -> pure $ P.BlobKey sha size + _ -> error $ "getBlobKey failed due to non-unique ID: " ++ show (bid, res) + +getBlobId :: BlobKey -> ReaderT SqlBackend (RIO env) (Maybe BlobId) +getBlobId (P.BlobKey sha size) = do + res <- rawSql "SELECT id FROM blob WHERE sha=? AND size=?" + [toPersistValue sha, toPersistValue size] + pure $ listToMaybe $ map unSingle res + +loadURLBlob :: Text -> ReaderT SqlBackend (RIO env) (Maybe ByteString) +loadURLBlob url = do + ment <- rawSql + "SELECT blob.contents\n\ + \FROM blob, url_blob\n\ + \WHERE url=?\ + \ AND url_blob.blob=blob.id\n\ + \ ORDER BY url_blob.time DESC" + [toPersistValue url] + case ment of + [] -> pure Nothing + (Single bs) : _ -> pure $ Just bs + +storeURLBlob :: Text -> ByteString -> ReaderT SqlBackend (RIO env) () +storeURLBlob url blob = do + (blobId, _) <- storeBlob blob + now <- getCurrentTime + insert_ UrlBlob + { urlBlobUrl = url + , urlBlobBlob = blobId + , urlBlobTime = now + } + +clearHackageRevisions :: ReaderT SqlBackend (RIO env) () +clearHackageRevisions = deleteWhere ([] :: [Filter HackageCabal]) + +storeHackageRevision :: + P.PackageName -> P.Version -> BlobId -> ReaderT SqlBackend (RIO env) () +storeHackageRevision name version key = do + nameid <- getPackageNameId name + versionid <- getVersionId version + rev <- count + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + ] + insert_ HackageCabal + { hackageCabalName = nameid + , hackageCabalVersion = versionid + , hackageCabalRevision = Revision (fromIntegral rev) + , hackageCabalCabal = key + , hackageCabalTree = Nothing + } + +loadHackagePackageVersions + :: P.PackageName + -> ReaderT SqlBackend (RIO env) (Map P.Version (Map Revision BlobKey)) +loadHackagePackageVersions name = do + nameid <- getPackageNameId name + -- would be better with esequeleto + (Map.fromListWith Map.union . map go) <$> rawSql + "SELECT hackage.revision, version.version, blob.sha, blob.size\n\ + \FROM hackage_cabal as hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=version.id\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid] + where + go (Single revision, Single (P.VersionP version), Single key, Single size) = + (version, Map.singleton revision (P.BlobKey key size)) + +loadHackagePackageVersion + :: P.PackageName + -> P.Version + -> ReaderT SqlBackend (RIO env) (Map Revision (BlobId, P.BlobKey)) +loadHackagePackageVersion name version = do + nameid <- getPackageNameId name + versionid <- getVersionId version + -- would be better with esequeleto + (Map.fromList . map go) <$> rawSql + "SELECT hackage.revision, blob.sha, blob.size, blob.id\n\ + \FROM hackage_cabal as hackage, version, blob\n\ + \WHERE hackage.name=?\n\ + \AND hackage.version=?\n\ + \AND hackage.cabal=blob.id" + [toPersistValue nameid, toPersistValue versionid] + where + go (Single revision, Single sha, Single size, Single bid) = + (revision, (bid, P.BlobKey sha size)) + +loadLatestCacheUpdate + :: ReaderT SqlBackend (RIO env) (Maybe (FileSize, SHA256)) +loadLatestCacheUpdate = + fmap go <$> selectFirst [] [Desc CacheUpdateTime] + where + go (Entity _ cu) = (cacheUpdateSize cu, cacheUpdateSha cu) + +storeCacheUpdate :: FileSize -> SHA256 -> ReaderT SqlBackend (RIO env) () +storeCacheUpdate size sha = do + now <- getCurrentTime + insert_ CacheUpdate + { cacheUpdateTime = now + , cacheUpdateSize = size + , cacheUpdateSha = sha + } + +storeHackageTarballInfo + :: P.PackageName + -> P.Version + -> SHA256 + -> FileSize + -> ReaderT SqlBackend (RIO env) () +storeHackageTarballInfo name version sha size = do + nameid <- getPackageNameId name + versionid <- getVersionId version + void $ insertBy HackageTarball + { hackageTarballName = nameid + , hackageTarballVersion = versionid + , hackageTarballSha = sha + , hackageTarballSize = size + } + +loadHackageTarballInfo + :: P.PackageName + -> P.Version + -> ReaderT SqlBackend (RIO env) (Maybe (SHA256, FileSize)) +loadHackageTarballInfo name version = do + nameid <- getPackageNameId name + versionid <- getVersionId version + fmap go <$> getBy (UniqueHackageTarball nameid versionid) + where + go (Entity _ ht) = (hackageTarballSha ht, hackageTarballSize ht) + +storeCabalFile :: + ByteString + -> P.PackageName + -> ReaderT SqlBackend (RIO env) BlobId +storeCabalFile cabalBS pkgName = do + (bid, _) <- storeBlob cabalBS + let cabalFile = P.cabalFileName pkgName + _ <- insertBy FilePath {filePathPath = cabalFile} + return bid + +loadFilePath :: + SafeFilePath + -> ReaderT SqlBackend (RIO env) (Entity FilePath) +loadFilePath path = do + fp <- getBy $ UniqueSfp path + case fp of + Nothing -> + error $ + "loadFilePath: No row found for " <> + (T.unpack $ P.unSafeFilePath path) + Just record -> return record + +loadHPackTreeEntity :: TreeId -> ReaderT SqlBackend (RIO env) (Entity TreeEntry) +loadHPackTreeEntity tid = do + filepath <- loadFilePath P.hpackSafeFilePath + let filePathId :: FilePathId = entityKey filepath + hpackTreeEntry <- + selectFirst [TreeEntryTree ==. tid, TreeEntryPath ==. filePathId] [] + case hpackTreeEntry of + Nothing -> + error $ + "loadHPackTreeEntity: No package.yaml file found in TreeEntry for TreeId: " ++ + show tid + Just record -> return record + +storeHPack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable + -> TreeId + -> ReaderT SqlBackend (RIO env) (Key HPack) +storeHPack rpli tid = do + vid <- hpackVersionId + hpackRecord <- getBy (UniqueHPack tid vid) + case hpackRecord of + Nothing -> generateHPack rpli tid vid + Just record -> return $ entityKey record + +loadCabalBlobKey :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey +loadCabalBlobKey hpackId = do + hpackRecord <- getJust hpackId + getBlobKey $ hPackCabalBlob hpackRecord + +generateHPack :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> TreeId + -> VersionId + -> ReaderT SqlBackend (RIO env) (Key HPack) +generateHPack rpli tid vid = do + tree <- getTree tid + (pkgName, cabalBS) <- hpackToCabalS rpli tree + bid <- storeCabalFile cabalBS pkgName + let cabalFile = P.cabalFileName pkgName + fid <- insertBy FilePath {filePathPath = cabalFile} + let hpackRecord = + HPack + { hPackTree = tid + , hPackVersion = vid + , hPackCabalBlob = bid + , hPackCabalPath = either entityKey id fid + } + either entityKey id <$> insertBy hpackRecord + + +hpackVersionId :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ReaderT SqlBackend (RIO env) VersionId +hpackVersionId = do + hpackSoftwareVersion <- lift hpackVersion + fmap (either entityKey id) $ + insertBy $ + Version {versionVersion = P.VersionP hpackSoftwareVersion} + + +getFilePathId :: SafeFilePath -> ReaderT SqlBackend (RIO env) FilePathId +getFilePathId sfp = + selectKeysList [FilePathPath ==. sfp] [] >>= \case + [fpId] -> pure fpId + [] -> + rdbmsAwareQuery + RdbmsActions + { raSqlite = insert $ FilePath sfp + , raPostgres = + do rawExecute + "INSERT INTO file_path(path) VALUES (?) ON CONFLICT DO NOTHING" + [toPersistValue sfp] + rawSql + "SELECT id FROM file_path WHERE path = ?" + [toPersistValue sfp] >>= \case + [Single key] -> pure key + _ -> + error + "getFilePathId: there was a critical problem storing a blob." + } + _ -> + error $ + "getFilePathId: FilePath unique constraint key is violated for: " ++ fp + where + fp = T.unpack (P.unSafeFilePath sfp) + + +storeTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.PackageIdentifier + -> P.Tree + -> P.BuildFile + -> ReaderT SqlBackend (RIO env) (TreeId, P.TreeKey) +storeTree rpli (P.PackageIdentifier name version) tree@(P.TreeMap m) buildFile = do + (bid, blobKey) <- storeBlob $ P.renderTree tree + (cabalid, ftype) <- case buildFile of + P.BFHpack (P.TreeEntry _ ftype) -> pure (Nothing, ftype) + P.BFCabal _ (P.TreeEntry (P.BlobKey btypeSha _) ftype) -> do + buildTypeid <- loadBlobBySHA btypeSha + buildid <- + case buildTypeid of + Just buildId -> pure buildId + Nothing -> error $ "storeTree: " ++ (show buildFile) ++ " BlobKey not found: " ++ show (tree, btypeSha) + return (Just buildid, ftype) + nameid <- getPackageNameId name + versionid <- getVersionId version + etid <- insertBy Tree + { treeKey = bid + , treeCabal = cabalid + , treeCabalType = ftype + , treeName = nameid + , treeVersion = versionid + } + + (tid, pTreeKey) <- case etid of + Left (Entity tid _) -> pure (tid, P.TreeKey blobKey) -- already in database, assume it matches + Right tid -> do + for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey' ft) -> do + sfpid <- getFilePathId sfp + mbid <- getBlobId blobKey' + bid' <- + case mbid of + Nothing -> error $ "Cannot store tree, contains unknown blob: " ++ show blobKey' + Just bid' -> pure bid' + insert_ TreeEntry + { treeEntryTree = tid + , treeEntryPath = sfpid + , treeEntryBlob = bid' + , treeEntryType = ft + } + pure (tid, P.TreeKey blobKey) + case buildFile of + P.BFHpack _ -> storeHPack rpli tid >> return () + P.BFCabal _ _ -> return () + return (tid, pTreeKey) + +getTree :: TreeId -> ReaderT SqlBackend (RIO env) P.Tree +getTree tid = do + (mts :: Maybe Tree) <- get tid + ts <- + case mts of + Nothing -> + error $ "getTree: invalid foreign key " ++ show tid + Just ts -> pure ts + loadTreeByEnt $ Entity tid ts + +loadTree :: P.TreeKey -> ReaderT SqlBackend (RIO env) (Maybe P.Tree) +loadTree key = do + ment <- getTreeForKey key + case ment of + Nothing -> pure Nothing + Just ent -> Just <$> loadTreeByEnt ent + +getTreeForKey + :: TreeKey + -> ReaderT SqlBackend (RIO env) (Maybe (Entity Tree)) +getTreeForKey (P.TreeKey key) = do + mbid <- getBlobId key + case mbid of + Nothing -> pure Nothing + Just bid -> getBy $ UniqueTree bid + +loadPackageById :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> TreeId + -> ReaderT SqlBackend (RIO env) Package +loadPackageById rpli tid = do + (mts :: Maybe Tree) <- get tid + ts <- + case mts of + Nothing -> + error $ "loadPackageById: invalid foreign key " ++ show tid + Just ts -> pure ts + (tree :: P.Tree) <- loadTreeByEnt $ Entity tid ts + (blobKey :: BlobKey) <- getBlobKey $ treeKey ts + (mname :: Maybe PackageName) <- get $ treeName ts + name <- + case mname of + Nothing -> + error $ + "loadPackageByid: invalid foreign key " ++ show (treeName ts) + Just (PackageName (P.PackageNameP name)) -> pure name + mversion <- get $ treeVersion ts + version <- + case mversion of + Nothing -> + error $ + "loadPackageByid: invalid foreign key " ++ show (treeVersion ts) + Just (Version (P.VersionP version)) -> pure version + let ident = P.PackageIdentifier name version + (packageEntry, mtree) <- + case treeCabal ts of + Just keyBlob -> do + cabalKey <- getBlobKey keyBlob + return + ( P.PCCabalFile $ P.TreeEntry cabalKey (treeCabalType ts) + , tree) + Nothing -> do + hpackVid <- hpackVersionId + hpackEntity <- getBy (UniqueHPack tid hpackVid) + let (P.TreeMap tmap) = tree + cabalFile = P.cabalFileName name + case hpackEntity of + Nothing + -- This case will happen when you either + -- update stack with a new hpack version or + -- use different hpack version via + -- --with-hpack option. + -> do + (hpackId :: HPackId) <- storeHPack rpli tid + hpackRecord <- getJust hpackId + getHPackCabalFile hpackRecord ts tmap cabalFile + Just (Entity _ item) -> + getHPackCabalFile item ts tmap cabalFile + pure + Package + { packageTreeKey = P.TreeKey blobKey + , packageTree = mtree + , packageCabalEntry = packageEntry + , packageIdent = ident + } + +getHPackBlobKey :: HPack -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKey hpackRecord = do + let treeId = hPackTree hpackRecord + hpackEntity <- loadHPackTreeEntity treeId + getBlobKey (treeEntryBlob $ entityVal hpackEntity) + +getHPackBlobKeyById :: HPackId -> ReaderT SqlBackend (RIO env) BlobKey +getHPackBlobKeyById hpackId = do + hpackRecord <- getJust hpackId + getHPackBlobKey hpackRecord + + +getHPackCabalFile :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => HPack + -> Tree + -> Map SafeFilePath P.TreeEntry + -> SafeFilePath + -> ReaderT SqlBackend (RIO env) (P.PackageCabal, P.Tree) +getHPackCabalFile hpackRecord ts tmap cabalFile = do + cabalKey <- getBlobKey (hPackCabalBlob hpackRecord) + hpackKey <- getHPackBlobKey hpackRecord + hpackSoftwareVersion <- lift hpackVersion + let fileType = treeCabalType ts + cbTreeEntry = P.TreeEntry cabalKey fileType + hpackTreeEntry = P.TreeEntry hpackKey fileType + tree = P.TreeMap $ Map.insert cabalFile cbTreeEntry tmap + return + ( P.PCHpack $ + P.PHpack + { P.phOriginal = hpackTreeEntry + , P.phGenerated = cbTreeEntry + , P.phVersion = hpackSoftwareVersion + } + , tree) + +loadTreeByEnt :: Entity Tree -> ReaderT SqlBackend (RIO env) P.Tree +loadTreeByEnt (Entity tid _t) = do + entries <- rawSql + "SELECT file_path.path, blob.sha, blob.size, tree_entry.type\n\ + \FROM tree_entry, blob, file_path\n\ + \WHERE tree_entry.tree=?\n\ + \AND tree_entry.blob=blob.id\n\ + \AND tree_entry.path=file_path.id" + [toPersistValue tid] + pure $ P.TreeMap $ Map.fromList $ map + (\(Single sfp, Single sha, Single size, Single ft) -> + (sfp, P.TreeEntry (P.BlobKey sha size) ft)) + entries + +storeHackageTree + :: P.PackageName + -> P.Version + -> BlobId + -> P.TreeKey + -> ReaderT SqlBackend (RIO env) () +storeHackageTree name version cabal treeKey' = do + nameid <- getPackageNameId name + versionid <- getVersionId version + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> updateWhere + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. cabal + ] + [HackageCabalTree =. Just (entityKey ent)] + +loadHackageTreeKey + :: P.PackageName + -> P.Version + -> SHA256 + -> ReaderT SqlBackend (RIO env) (Maybe TreeKey) +loadHackageTreeKey name ver sha = do + res <- rawSql + "SELECT treeblob.sha, treeblob.size\n\ + \FROM blob as treeblob, blob as cabalblob, package_name, version, hackage_cabal, tree\n\ + \WHERE package_name.name=?\n\ + \AND version.version=?\n\ + \AND cabalblob.sha=?\n\ + \AND hackage_cabal.name=package_name.id\n\ + \AND hackage_cabal.version=version.id\n\ + \AND hackage_cabal.cabal=cabalblob.id\n\ + \AND hackage_cabal.tree=tree.id\n\ + \AND tree.key=treeblob.id" + [ toPersistValue $ P.PackageNameP name + , toPersistValue $ P.VersionP ver + , toPersistValue sha + ] + case res of + [] -> pure Nothing + (Single treesha, Single size):_ -> + pure $ Just $ P.TreeKey $ P.BlobKey treesha size + +loadHackageTree + :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.PackageName + -> P.Version + -> BlobId + -> ReaderT SqlBackend (RIO env) (Maybe Package) +loadHackageTree rpli name ver bid = do + nameid <- getPackageNameId name + versionid <- getVersionId ver + ment <- selectFirst + [ HackageCabalName ==. nameid + , HackageCabalVersion ==. versionid + , HackageCabalCabal ==. bid + , HackageCabalTree !=. Nothing + ] + [] + case ment of + Nothing -> pure Nothing + Just (Entity _ hc) -> + case hackageCabalTree hc of + Nothing -> assert False $ pure Nothing + Just tid -> Just <$> loadPackageById rpli tid + +storeArchiveCache + :: Text -- ^ URL + -> Text -- ^ subdir + -> SHA256 + -> FileSize + -> P.TreeKey + -> ReaderT SqlBackend (RIO env) () +storeArchiveCache url subdir sha size treeKey' = do + now <- getCurrentTime + ment <- getTreeForKey treeKey' + for_ ment $ \ent -> insert_ ArchiveCache + { archiveCacheTime = now + , archiveCacheUrl = url + , archiveCacheSubdir = subdir + , archiveCacheSha = sha + , archiveCacheSize = size + , archiveCacheTree = entityKey ent + } + +loadArchiveCache + :: Text -- ^ URL + -> Text -- ^ subdir + -> ReaderT SqlBackend (RIO env) [(SHA256, FileSize, TreeId)] +loadArchiveCache url subdir = map go <$> selectList + [ ArchiveCacheUrl ==. url + , ArchiveCacheSubdir ==. subdir + ] + [Desc ArchiveCacheTime] + where + go (Entity _ ac) = (archiveCacheSha ac, archiveCacheSize ac, archiveCacheTree ac) + +storeRepoCache + :: Repo + -> Text -- ^ subdir + -> TreeId + -> ReaderT SqlBackend (RIO env) () +storeRepoCache repo subdir tid = do + now <- getCurrentTime + insert_ RepoCache + { repoCacheTime = now + , repoCacheUrl = repoUrl repo + , repoCacheType = repoType repo + , repoCacheCommit = repoCommit repo + , repoCacheSubdir = subdir + , repoCacheTree = tid + } + +loadRepoCache + :: Repo + -> Text -- ^ subdir + -> ReaderT SqlBackend (RIO env) (Maybe TreeId) +loadRepoCache repo subdir = fmap (repoCacheTree . entityVal) <$> selectFirst + [ RepoCacheUrl ==. repoUrl repo + , RepoCacheType ==. repoType repo + , RepoCacheCommit ==. repoCommit repo + , RepoCacheSubdir ==. subdir + ] + [Desc RepoCacheTime] + +storePreferredVersion :: + P.PackageName -> Text -> ReaderT SqlBackend (RIO env) () +storePreferredVersion name p = do + nameid <- getPackageNameId name + ment <- getBy $ UniquePreferred nameid + case ment of + Nothing -> insert_ PreferredVersions + { preferredVersionsName = nameid + , preferredVersionsPreferred = p + } + Just (Entity pid _) -> update pid [PreferredVersionsPreferred =. p] + +loadPreferredVersion :: + P.PackageName -> ReaderT SqlBackend (RIO env) (Maybe Text) +loadPreferredVersion name = do + nameid <- getPackageNameId name + fmap (preferredVersionsPreferred . entityVal) <$> getBy (UniquePreferred nameid) + +sinkHackagePackageNames + :: (P.PackageName -> Bool) + -> ConduitT P.PackageName Void (ReaderT SqlBackend (RIO env)) a + -> ReaderT SqlBackend (RIO env) a +sinkHackagePackageNames predicate sink = do + acqSrc <- selectSourceRes [] [] + with acqSrc $ \src -> runConduit + $ src + .| concatMapMC go + .| sink + where + go (Entity nameid (PackageName (PackageNameP name))) + | predicate name = do + -- Make sure it's actually on Hackage. Would be much more + -- efficient with some raw SQL and an inner join, but we + -- don't have a Conduit version of rawSql. + onHackage <- checkOnHackage nameid + pure $ if onHackage then Just name else Nothing + | otherwise = pure Nothing + + checkOnHackage nameid = do + cnt <- count [HackageCabalName ==. nameid] + pure $ cnt > 0 + +-- | Get the filename for the cabal file in the given directory. +-- +-- If no .cabal file is present, or more than one is present, an exception is +-- thrown via 'throwM'. +-- +-- If the directory contains a file named package.yaml, hpack is used to +-- generate a .cabal file from it. +findOrGenerateCabalFile + :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Path Abs Dir -- ^ package directory + -> RIO env (P.PackageName, Path Abs File) +findOrGenerateCabalFile pkgDir = do + hpack pkgDir + files <- filter (flip hasExtension "cabal" . toFilePath) . snd + <$> listDir pkgDir + -- If there are multiple files, ignore files that start with + -- ".". On unixlike environments these are hidden, and this + -- character is not valid in package names. The main goal is + -- to ignore emacs lock files - see + -- https://github.com/commercialhaskell/stack/issues/1897. + let isHidden ('.':_) = True + isHidden _ = False + case filter (not . isHidden . fromRelFile . filename) files of + [] -> throwIO $ P.NoCabalFileFound pkgDir + [x] -> maybe + (throwIO $ P.InvalidCabalFilePath x) + (\pn -> pure $ (pn, x)) $ + List.stripSuffix ".cabal" (toFilePath (filename x)) >>= + P.parsePackageName + _:_ -> throwIO $ P.MultipleCabalFilesFound pkgDir files + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x + +-- | Similar to 'hpackToCabal' but doesn't require a new connection to database. +hpackToCabalS :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> ReaderT SqlBackend (RIO env) (P.PackageName, ByteString) +hpackToCabalS rpli tree = do + tmpDir <- lift $ do + tdir <- getTempDir + createTempDir tdir "hpack-pkg-dir" + unpackTreeToDir rpli tmpDir tree + (packageName, cfile) <- lift $ findOrGenerateCabalFile tmpDir + !bs <- lift $ B.readFile (fromAbsFile cfile) + lift $ removeDirRecur tmpDir + return $ (packageName, bs) + +hpackToCabal :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> P.Tree + -> RIO env (P.PackageName, ByteString) +hpackToCabal rpli tree = withSystemTempDirectory "hpack-pkg-dir" $ \tmpdir -> do + tdir <- parseAbsDir tmpdir + withStorage $ unpackTreeToDir rpli tdir tree + (packageName, cfile) <- findOrGenerateCabalFile tdir + bs <- B.readFile (fromAbsFile cfile) + return (packageName, bs) + +unpackTreeToDir + :: (HasPantryConfig env, HasLogFunc env) + => P.RawPackageLocationImmutable -- ^ for exceptions + -> Path Abs Dir -- ^ dest dir, will be created if necessary + -> P.Tree + -> ReaderT SqlBackend (RIO env) () +unpackTreeToDir rpli (toFilePath -> dir) (P.TreeMap m) = do + for_ (Map.toList m) $ \(sfp, P.TreeEntry blobKey ft) -> do + let dest = dir T.unpack (P.unSafeFilePath sfp) + createDirectoryIfMissing True $ takeDirectory dest + mbs <- loadBlob blobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire stuff, try downloading + throwIO $ P.TreeReferencesMissingBlob rpli sfp blobKey + Just bs -> do + B.writeFile dest bs + case ft of + FTNormal -> pure () + FTExecutable -> liftIO $ do + perms <- getPermissions dest + setPermissions dest $ setOwnerExecutable True perms + +countHackageCabals :: ReaderT SqlBackend (RIO env) Int +countHackageCabals = do + res <- rawSql + "SELECT COUNT(*)\n\ + \FROM hackage_cabal" + [] + case res of + [] -> pure 0 + (Single n):_ -> + pure n + +getSnapshotCacheByHash + :: SnapshotCacheHash + -> ReaderT SqlBackend (RIO env) (Maybe SnapshotCacheId) +getSnapshotCacheByHash = + fmap (fmap entityKey) . getBy . UniqueSnapshotCache . unSnapshotCacheHash + +getSnapshotCacheId + :: SnapshotCacheHash + -> ReaderT SqlBackend (RIO env) SnapshotCacheId +getSnapshotCacheId = + fmap (either entityKey id) . insertBy . SnapshotCache . unSnapshotCacheHash + +getModuleNameId + :: P.ModuleName + -> ReaderT SqlBackend (RIO env) ModuleNameId +getModuleNameId = + fmap (either entityKey id) . insertBy . ModuleName . P.ModuleNameP + +storeSnapshotModuleCache + :: SnapshotCacheId + -> Map P.PackageName (Set P.ModuleName) + -> ReaderT SqlBackend (RIO env) () +storeSnapshotModuleCache cache packageModules = + forM_ (Map.toList packageModules) $ \(pn, modules) -> do + package <- getPackageNameId pn + forM_ modules $ \m -> do + moduleName <- getModuleNameId m + insert_ PackageExposedModule + { packageExposedModuleSnapshotCache = cache + , packageExposedModulePackage = package + , packageExposedModuleModule = moduleName + } + +loadExposedModulePackages + :: SnapshotCacheId + -> P.ModuleName + -> ReaderT SqlBackend (RIO env) [P.PackageName] +loadExposedModulePackages cacheId mName = + map go <$> rawSql + "SELECT package_name.name\n\ + \FROM package_name, package_exposed_module, module_name\n\ + \WHERE module_name.name=?\n\ + \AND package_exposed_module.snapshot_cache=?\n\ + \AND module_name.id=package_exposed_module.module\n\ + \AND package_name.id=package_exposed_module.package" + [ toPersistValue (P.ModuleNameP mName) + , toPersistValue cacheId + ] + where + go (Single (P.PackageNameP m)) = m diff --git a/src/Pantry/Tree.hs b/src/Pantry/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Tree.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Pantry.Tree + ( unpackTree + , rawParseGPD + ) where + +import RIO +import qualified RIO.Map as Map +import qualified RIO.Text as T +import qualified RIO.ByteString as B +import Pantry.Storage hiding (Tree, TreeEntry) +import Pantry.Types +import RIO.FilePath ((), takeDirectory) +import RIO.Directory (createDirectoryIfMissing, setPermissions, getPermissions, setOwnerExecutable) +import Path (Path, Abs, Dir, toFilePath) +import Distribution.Parsec.Common (PWarning (..)) +import Distribution.PackageDescription (GenericPackageDescription) +import Distribution.PackageDescription.Parsec +import Path (File) + +unpackTree + :: (HasPantryConfig env, HasLogFunc env) + => RawPackageLocationImmutable -- for exceptions + -> Path Abs Dir -- ^ dest dir, will be created if necessary + -> Tree + -> RIO env () +unpackTree rpli (toFilePath -> dir) (TreeMap m) = do + withStorage $ for_ (Map.toList m) $ \(sfp, TreeEntry blobKey ft) -> do + let dest = dir T.unpack (unSafeFilePath sfp) + createDirectoryIfMissing True $ takeDirectory dest + mbs <- loadBlob blobKey + case mbs of + Nothing -> do + -- TODO when we have pantry wire stuff, try downloading + throwIO $ TreeReferencesMissingBlob rpli sfp blobKey + Just bs -> do + B.writeFile dest bs + case ft of + FTNormal -> pure () + FTExecutable -> liftIO $ do + perms <- getPermissions dest + setPermissions dest $ setOwnerExecutable True perms + +-- | A helper function that performs the basic character encoding +-- necessary. +rawParseGPD + :: MonadThrow m + => Either RawPackageLocationImmutable (Path Abs File) + -> ByteString + -> m ([PWarning], GenericPackageDescription) +rawParseGPD loc bs = + case eres of + Left (mversion, errs) -> throwM $ InvalidCabalFile loc mversion errs warnings + Right gpkg -> return (warnings, gpkg) + where + (warnings, eres) = runParseResult $ parseGenericPackageDescription bs diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs new file mode 100644 --- /dev/null +++ b/src/Pantry/Types.hs @@ -0,0 +1,2274 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} +module Pantry.Types + ( PantryConfig (..) + , HackageSecurityConfig (..) + , Storage (..) + , HasPantryConfig (..) + , BlobKey (..) + , PackageName + , Version + , PackageIdentifier (..) + , Revision (..) + , ModuleName + , CabalFileInfo (..) + , PrintWarnings (..) + , PackageNameP (..) + , VersionP (..) + , ModuleNameP (..) + , PackageIdentifierRevision (..) + , pirForHash + , FileType (..) + , BuildFile (..) + , FileSize (..) + , TreeEntry (..) + , SafeFilePath + , unSafeFilePath + , mkSafeFilePath + , safeFilePathtoPath + , hpackSafeFilePath + , TreeKey (..) + , Tree (..) + , renderTree + , parseTree + , SHA256 + , Unresolved + , resolvePaths + , Package (..) + , PackageCabal (..) + , PHpack (..) + -- , PackageTarball (..) + , RawPackageLocation (..) + , PackageLocation (..) + , toRawPL + , RawPackageLocationImmutable (..) + , PackageLocationImmutable (..) + , toRawPLI + , RawArchive (..) + , Archive (..) + , toRawArchive + , Repo (..) + , RepoType (..) + , parsePackageIdentifier + , parsePackageName + , parsePackageNameThrowing + , parseFlagName + , parseVersion + , parseVersionThrowing + , packageIdentifierString + , packageNameString + , flagNameString + , versionString + , moduleNameString + , OptionalSubdirs (..) + , ArchiveLocation (..) + , RelFilePath (..) + , CabalString (..) + , toCabalStringMap + , unCabalStringMap + , parsePackageIdentifierRevision + , Mismatch (..) + , PantryException (..) + , FuzzyResults (..) + , ResolvedPath (..) + , HpackExecutable (..) + , WantedCompiler (..) + --, resolveSnapshotLocation + , ltsSnapshotLocation + , nightlySnapshotLocation + , RawSnapshotLocation (..) + , SnapshotLocation (..) + , toRawSL + , parseHackageText + , parseRawSnapshotLocation + , RawSnapshotLayer (..) + , SnapshotLayer (..) + , toRawSnapshotLayer + , RawSnapshot (..) + , Snapshot (..) + , RawSnapshotPackage (..) + , SnapshotPackage (..) + , parseWantedCompiler + , RawPackageMetadata (..) + , PackageMetadata (..) + , toRawPM + , cabalFileName + , SnapshotCacheHash (..) + , getGlobalHintsFile + , bsToBlobKey + ) where + +import RIO +import qualified Data.Conduit.Tar as Tar +import qualified RIO.Text as T +import qualified RIO.ByteString as B +import qualified RIO.ByteString.Lazy as BL +import RIO.Char (isSpace) +import RIO.List (intersperse) +import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime) +import qualified RIO.Map as Map +import qualified RIO.HashMap as HM +import qualified Data.Map.Strict as Map (mapKeysMonotonic) +import qualified RIO.Set as Set +import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..)) +import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser) +import Pantry.Internal.AesonExtended +import Data.Aeson.Encoding.Internal (unsafeToEncoding) +import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) +import Database.Persist +import Database.Persist.Sql +import Pantry.SHA256 (SHA256) +import qualified Pantry.SHA256 as SHA256 +import qualified Distribution.Compat.ReadP as Parse +import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) +import Distribution.Parsec.Common (PError (..), PWarning (..), showPos) +import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) +import Distribution.Types.VersionRange (VersionRange) +import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import qualified Distribution.Text +import qualified Hpack.Config as Hpack +import Distribution.ModuleName (ModuleName) +import Distribution.Types.Version (Version, mkVersion) +import Network.HTTP.Client (parseRequest) +import Network.HTTP.Types (Status, statusCode) +import Data.Text.Read (decimal) +import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) +import Path.IO (resolveFile, resolveDir) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE + +-- | Parsed tree with more information on the Haskell package it contains. +-- +-- @since 0.1.0.0 +data Package = Package + { packageTreeKey :: !TreeKey + -- ^ The 'TreeKey' containing this package. + -- + -- This is a hash of the binary representation of 'packageTree'. + -- + -- @since 0.1.0.0 + , packageTree :: !Tree + -- ^ The 'Tree' containing this package. + -- + -- @since 0.1.0.0 + , packageCabalEntry :: !PackageCabal + -- ^ Information on the cabal file inside this package. + -- + -- @since 0.1.0.0 + , packageIdent :: !PackageIdentifier + -- ^ The package name and version in this package. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq) + +data PHpack = PHpack + { + phOriginal :: !TreeEntry, -- ^ Original hpack file + phGenerated :: !TreeEntry, -- ^ Generated Cabal file + phVersion :: !Version -- ^ Version of Hpack used + } deriving (Show, Eq) + +data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file + | PCHpack !PHpack + deriving (Show, Eq) + +cabalFileName :: PackageName -> SafeFilePath +cabalFileName name = + case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of + Nothing -> error $ "cabalFileName: failed for " ++ show name + Just sfp -> sfp + +-- | The revision number of a package from Hackage, counting upwards +-- from 0 (the original cabal file). +-- +-- See caveats on 'CFIRevision'. +-- +-- @since 0.1.0.0 +newtype Revision = Revision Word + deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) + +-- | Represents a SQL database connection. This used to be a newtype +-- wrapper around a connection pool. However, when investigating +-- , 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 +-- . +-- +-- @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 +-- . +-- +-- @since 0.1.0.0 +data BlobKey = BlobKey !SHA256 !FileSize + deriving (Eq, Ord, Typeable, Generic) +instance NFData BlobKey + +instance Show BlobKey where + show = T.unpack . utf8BuilderToText . display +instance Display BlobKey where + display (BlobKey sha size') = display sha <> "," <> display size' + +blobKeyPairs :: BlobKey -> [(Text, Value)] +blobKeyPairs (BlobKey sha size') = + [ "sha256" .= sha + , "size" .= size' + ] + +instance ToJSON BlobKey where + toJSON = object . blobKeyPairs +instance FromJSON BlobKey where + parseJSON = withObject "BlobKey" $ \o -> BlobKey + <$> o .: "sha256" + <*> o .: "size" + +newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } + deriving (Eq, Ord, Show, Read, NFData) +instance Display PackageNameP where + display = fromString . packageNameString . unPackageNameP +instance PersistField PackageNameP where + toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn + fromPersistValue v = do + str <- fromPersistValue v + case parsePackageName str of + Nothing -> Left $ "Invalid package name: " <> T.pack str + Just pn -> Right $ PackageNameP pn +instance PersistFieldSql PackageNameP where + sqlType _ = SqlString +instance ToJSON PackageNameP where + toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn +instance FromJSON PackageNameP where + parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack +instance ToJSONKey PackageNameP where + toJSONKey = + ToJSONKeyText + (T.pack . packageNameString . unPackageNameP) + (unsafeToEncoding . getUtf8Builder . display) +instance FromJSONKey PackageNameP where + fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack + +newtype VersionP = VersionP { unVersionP :: Version } + deriving (Eq, Ord, Show, Read, NFData) +instance PersistField VersionP where + toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v + fromPersistValue v = do + str <- fromPersistValue v + case parseVersion str of + Nothing -> Left $ "Invalid version number: " <> T.pack str + Just ver -> Right $ VersionP ver +instance PersistFieldSql VersionP where + sqlType _ = SqlString +instance Display VersionP where + display (VersionP v) = fromString $ versionString v +instance ToJSON VersionP where + toJSON (VersionP v) = String $ T.pack $ versionString v +instance FromJSON VersionP where + parseJSON = + withText "VersionP" $ + either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack + +newtype ModuleNameP = ModuleNameP + { unModuleNameP :: ModuleName + } deriving (Eq, Ord, Show, NFData) +instance Display ModuleNameP where + display = fromString . moduleNameString . unModuleNameP +instance PersistField ModuleNameP where + toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn + fromPersistValue v = do + str <- fromPersistValue v + case parseModuleName str of + Nothing -> Left $ "Invalid module name: " <> T.pack str + Just pn -> Right $ ModuleNameP pn +instance PersistFieldSql ModuleNameP where + sqlType _ = SqlString + +-- | How to choose a cabal file for a package from Hackage. This is to +-- work with Hackage cabal file revisions, which makes +-- @PackageIdentifier@ insufficient for specifying a package from +-- Hackage. +-- +-- @since 0.1.0.0 +data CabalFileInfo + = CFILatest + -- ^ Take the latest revision of the cabal file available. This + -- isn't reproducible at all, but the running assumption (not + -- necessarily true) is that cabal file revisions do not change + -- semantics of the build. + -- + -- @since 0.1.0.0 + | CFIHash !SHA256 !(Maybe FileSize) + -- ^ Identify by contents of the cabal file itself. Only reason for + -- @Maybe@ on @FileSize@ is for compatibility with input that + -- doesn't include the file size. + -- + -- @since 0.1.0.0 + | CFIRevision !Revision + -- ^ Identify by revision number, with 0 being the original and + -- counting upward. This relies on Hackage providing consistent + -- versioning. @CFIHash@ should be preferred wherever possible for + -- reproducibility. + -- + -- @since 0.1.0.0 + deriving (Generic, Show, Eq, Ord, Typeable) +instance NFData CabalFileInfo +instance Hashable CabalFileInfo + +instance Display CabalFileInfo where + display CFILatest = mempty + display (CFIHash hash' msize) = + "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize + display (CFIRevision rev) = "@rev:" <> display rev + +-- | A full specification for a package from Hackage, including the +-- package name, version, and how to load up the correct cabal file +-- revision. +-- +-- @since 0.1.0.0 +data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo + deriving (Generic, Eq, Ord, Typeable) +instance NFData PackageIdentifierRevision + +instance Show PackageIdentifierRevision where + show = T.unpack . utf8BuilderToText . display + +instance Display PackageIdentifierRevision where + display (PackageIdentifierRevision name version cfi) = + fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi + +instance ToJSON PackageIdentifierRevision where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON PackageIdentifierRevision where + parseJSON = withText "PackageIdentifierRevision" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure pir + +-- | Parse a hackage text. +-- +-- @since 0.1.0.0 +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + (csha, csize) <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ (sha, FileSize size') + _ -> Nothing + pure msize + _ -> Nothing + pure $ (PackageIdentifier name version, BlobKey csha csize) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + +-- | Parse a 'PackageIdentifierRevision' +-- +-- @since 0.1.0.0 +parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision +parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + cfi <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Just Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ Just $ FileSize size' + _ -> Nothing + pure $ CFIHash sha msize + Just ("@rev", revT) -> + case decimal revT of + Right (rev, "") -> pure $ CFIRevision $ Revision rev + _ -> Nothing + Nothing -> pure CFILatest + _ -> Nothing + pure $ PackageIdentifierRevision name version cfi + +data Mismatch a = Mismatch + { mismatchExpected :: !a + , mismatchActual :: !a + } + +-- | Things that can go wrong in pantry. Note two things: +-- +-- * Many other exception types may be thrown from underlying +-- libraries. Pantry does not attempt to wrap these underlying +-- exceptions. +-- +-- * We may add more constructors to this data type in minor version +-- bumps of pantry. This technically breaks the PVP. You should not +-- be writing pattern matches against this type that expect total +-- matching. +-- +-- @since 0.1.0.0 +data PantryException + = PackageIdentifierRevisionParseFail !Text + | InvalidCabalFile + !(Either RawPackageLocationImmutable (Path Abs File)) + !(Maybe Version) + ![PError] + ![PWarning] + | TreeWithoutCabalFile !RawPackageLocationImmutable + | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] + | MismatchedCabalName !(Path Abs File) !PackageName + | NoCabalFileFound !(Path Abs Dir) + | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] + | InvalidWantedCompiler !Text + | InvalidSnapshotLocation !(Path Abs Dir) !Text + | InvalidOverrideCompiler !WantedCompiler !WantedCompiler + | InvalidFilePathSnapshot !Text + | InvalidSnapshot !RawSnapshotLocation !SomeException + | MismatchedPackageMetadata + !RawPackageLocationImmutable + !RawPackageMetadata + !(Maybe TreeKey) + !BlobKey -- cabal file found + !PackageIdentifier + | Non200ResponseStatus !Status + | InvalidBlobKey !(Mismatch BlobKey) + | Couldn'tParseSnapshot !RawSnapshotLocation !String + | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName + | DownloadInvalidSHA256 !Text !(Mismatch SHA256) + | DownloadInvalidSize !Text !(Mismatch FileSize) + | DownloadTooLarge !Text !(Mismatch FileSize) + -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is + -- a lower bound on the size from the server. + | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) + | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) + | UnknownArchiveType !ArchiveLocation + | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType + | UnsupportedTarball !ArchiveLocation !Text + | NoHackageCryptographicHash !PackageIdentifier + | FailedToCloneRepo !Repo + | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey + | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata + | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) + | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults + | CannotCompleteRepoNonSHA1 !Repo + | MutablePackageLocationFromUrl !Text + | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) + | PackageNameParseFail !Text + | PackageVersionParseFail !Text + | InvalidCabalFilePath !(Path Abs File) + | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] + | MigrationFailure !Text !(Path Abs File) !SomeException + + deriving Typeable +instance Exception PantryException where +instance Show PantryException where + show = T.unpack . utf8BuilderToText . display +instance Display PantryException where + display (PackageIdentifierRevisionParseFail text) = + "Invalid package identifier (with optional revision): " <> + display text + display (InvalidCabalFile loc mversion errs warnings) = + "Unable to parse cabal file from package " <> + either display (fromString . toFilePath) loc <> + "\n\n" <> + foldMap + (\(PError pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + errs <> + foldMap + (\(PWarning _ pos msg) -> + "- " <> + fromString (showPos pos) <> + ": " <> + fromString msg <> + "\n") + warnings <> + + (case mversion of + Just version + | version > cabalSpecLatestVersion -> + "\n\nThe cabal file uses the cabal specification version " <> + fromString (versionString version) <> + ", but we only support up to version " <> + fromString (versionString cabalSpecLatestVersion) <> + ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." + _ -> mempty) + display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl + display (TreeWithMultipleCabalFiles pl sfps) = + "Multiple cabal files found for " <> display pl <> ": " <> + fold (intersperse ", " (map display sfps)) + display (MismatchedCabalName fp name) = + "cabal file path " <> + fromString (toFilePath fp) <> + " does not match the package name it defines.\n" <> + "Please rename the file to: " <> + fromString (packageNameString name) <> + ".cabal\n" <> + "For more information, see: https://github.com/commercialhaskell/stack/issues/317" + display (NoCabalFileFound dir) = + "Stack looks for packages in the directories configured in\n" <> + "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> + "The current entry points to " <> + fromString (toFilePath dir) <> + ",\nbut no .cabal or package.yaml file could be found there." + display (MultipleCabalFilesFound dir files) = + "Multiple .cabal files found in directory " <> + fromString (toFilePath dir) <> + ":\n" <> + fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) + display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t + display (InvalidSnapshotLocation dir t) = + "Invalid snapshot location " <> + displayShow t <> + " relative to directory " <> + displayShow (toFilePath dir) + display (InvalidOverrideCompiler x y) = + "Specified compiler for a resolver (" <> + display x <> + "), but also specified an override compiler (" <> + display y <> + ")" + display (InvalidFilePathSnapshot t) = + "Specified snapshot as file path with " <> + displayShow t <> + ", but not reading from a local file" + display (InvalidSnapshot loc e) = + "Exception while reading snapshot from " <> + display loc <> + ":\n" <> + displayShow e + display (MismatchedPackageMetadata loc pm mtreeKey foundCabal foundIdent) = + "Mismatched package metadata for " <> display loc <> + "\nFound: " <> fromString (packageIdentifierString foundIdent) <> " with cabal file " <> + display foundCabal <> + (case mtreeKey of + Nothing -> mempty + Just treeKey -> " and tree " <> display treeKey) <> + "\nExpected: " <> display pm + display (Non200ResponseStatus status) = + "Unexpected non-200 HTTP status code: " <> + displayShow (statusCode status) + display (InvalidBlobKey Mismatch{..}) = + "Invalid blob key found, expected: " <> + display mismatchExpected <> + ", actual: " <> + display mismatchActual + display (Couldn'tParseSnapshot sl e) = + "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e + display (WrongCabalFileName pl sfp name) = + "Wrong cabal file name for package " <> display pl <> + "\nCabal file is named " <> display sfp <> + ", but package name is " <> fromString (packageNameString name) <> + "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" + display (DownloadInvalidSHA256 url Mismatch {..}) = + "Mismatched SHA256 hash from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadInvalidSize url Mismatch {..}) = + "Mismatched download size from " <> display url <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (DownloadTooLarge url Mismatch {..}) = + "Download from " <> display url <> " was too large.\n" <> + "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> + display mismatchActual + display (LocalInvalidSHA256 path Mismatch {..}) = + "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (LocalInvalidSize path Mismatch {..}) = + "Mismatched file size from " <> fromString (toFilePath path) <> + "\nExpected: " <> display mismatchExpected <> + "\nActual: " <> display mismatchActual + display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc + display (InvalidTarFileType loc fp x) = + "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x + display (UnsupportedTarball loc e) = + "Unsupported tarball from " <> display loc <> ": " <> display e + display (NoHackageCryptographicHash ident) = + "Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) + display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo + display (TreeReferencesMissingBlob loc sfp key) = + "The package " <> display loc <> + " needs blob " <> display key <> + " for file path " <> display sfp <> + ", but the blob is not available" + display (CompletePackageMetadataMismatch loc pm) = + "When completing package metadata for " <> display loc <> + ", some values changed in the new package metadata: " <> + display pm + display (CRC32Mismatch loc fp Mismatch {..}) = + "CRC32 mismatch in ZIP file from " <> display loc <> + " on internal file " <> fromString fp <> + "\n.Expected: " <> display mismatchExpected <> + "\n.Actual: " <> display mismatchActual + display (UnknownHackagePackage pir fuzzy) = + "Could not find " <> display pir <> " on Hackage" <> + displayFuzzy fuzzy + display (CannotCompleteRepoNonSHA1 repo) = + "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> + display repo + display (MutablePackageLocationFromUrl t) = + "Cannot refer to a mutable package location from a URL: " <> display t + display (MismatchedCabalFileForHackage pir Mismatch{..}) = + "When processing cabal file for Hackage package " <> display pir <> + ":\nMismatched package identifier." <> + "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> + "\nActual: " <> fromString (packageIdentifierString mismatchActual) + display (PackageNameParseFail t) = + "Invalid package name: " <> display t + display (PackageVersionParseFail t) = + "Invalid version: " <> display t + display (InvalidCabalFilePath fp) = + "File path contains a name which is not a valid package name: " <> + fromString (toFilePath fp) + display (DuplicatePackageNames source pairs') = + "Duplicate package names (" <> source <> "):\n" <> + foldMap + (\(name, locs) -> + fromString (packageNameString name) <> ":\n" <> + foldMap + (\loc -> "- " <> display loc <> "\n") + locs + ) + pairs' + display (MigrationFailure desc fp ex) = + "Encountered error while migrating " <> display desc <> " database:" <> + "\n " <> displayShow ex <> + "\nPlease report this on https://github.com/commercialhaskell/stack/issues" <> + "\nAs a workaround you may delete " <> display desc <> " database in " <> + fromString (toFilePath fp) <> " triggering its recreation." + +data FuzzyResults + = FRNameNotFound ![PackageName] + | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) + | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) + +displayFuzzy :: FuzzyResults -> Utf8Builder +displayFuzzy (FRNameNotFound names) = + case NE.nonEmpty names of + Nothing -> "" + Just names' -> + "\nPerhaps you meant " <> + orSeparated (NE.map (fromString . packageNameString) names') <> + "?" +displayFuzzy (FRVersionNotFound pirs) = + "\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." +displayFuzzy (FRRevisionNotFound pirs) = + "\nThe specified revision was not found.\nPossible candidates: " <> + commaSeparated (NE.map display pirs) <> + "." + +orSeparated :: NonEmpty Utf8Builder -> Utf8Builder +orSeparated xs + | NE.length xs == 1 = NE.head xs + | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs + | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs + +commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder +commaSeparated = fold . NE.intersperse ", " + +-- You'd really think there'd be a better way to do this in Cabal. +cabalSpecLatestVersion :: Version +cabalSpecLatestVersion = + case cabalSpecLatest of + CabalSpecOld -> error "this cannot happen" + CabalSpecV1_22 -> error "this cannot happen" + CabalSpecV1_24 -> error "this cannot happen" + CabalSpecV2_0 -> error "this cannot happen" + CabalSpecV2_2 -> error "this cannot happen" + CabalSpecV2_4 -> mkVersion [2, 4] + +data BuildFile = BFCabal !SafeFilePath !TreeEntry + | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file + deriving (Show, Eq) + +data FileType = FTNormal | FTExecutable + deriving (Show, Eq, Enum, Bounded) +instance PersistField FileType where + toPersistValue FTNormal = PersistInt64 1 + toPersistValue FTExecutable = PersistInt64 2 + + fromPersistValue v = do + i <- fromPersistValue v + case i :: Int64 of + 1 -> Right FTNormal + 2 -> Right FTExecutable + _ -> Left $ "Invalid FileType: " <> tshow i +instance PersistFieldSql FileType where + sqlType _ = SqlInt32 + +data TreeEntry = TreeEntry + { teBlob :: !BlobKey + , teType :: !FileType + } + deriving (Show, Eq) + +newtype SafeFilePath = SafeFilePath Text + deriving (Show, Eq, Ord, Display) + +instance PersistField SafeFilePath where + toPersistValue = toPersistValue . unSafeFilePath + fromPersistValue v = do + t <- fromPersistValue v + maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t +instance PersistFieldSql SafeFilePath where + sqlType _ = SqlString + +unSafeFilePath :: SafeFilePath -> Text +unSafeFilePath (SafeFilePath t) = t + +safeFilePathtoPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) +safeFilePathtoPath dir (SafeFilePath path) = do + fpath <- parseRelFile (T.unpack path) + return $ dir fpath + +mkSafeFilePath :: Text -> Maybe SafeFilePath +mkSafeFilePath t = do + guard $ not $ "\\" `T.isInfixOf` t + guard $ not $ "//" `T.isInfixOf` t + guard $ not $ "\n" `T.isInfixOf` t + guard $ not $ "\0" `T.isInfixOf` t + + (c, _) <- T.uncons t + guard $ c /= '/' + + guard $ all (not . T.all (== '.')) $ T.split (== '/') t + + Just $ SafeFilePath t + +-- | SafeFilePath for `package.yaml` file. +hpackSafeFilePath :: SafeFilePath +hpackSafeFilePath = + let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) + in case fpath of + Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) + Just sfp -> sfp + +-- | The hash of the binary representation of a 'Tree'. +-- +-- @since 0.1.0.0 +newtype TreeKey = TreeKey BlobKey + deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) + +-- | Represents the contents of a tree, which is a mapping from +-- relative file paths to 'TreeEntry's. +-- +-- @since 0.1.0.0 +newtype Tree + = TreeMap (Map SafeFilePath TreeEntry) + -- In the future, consider allowing more lax parsing + -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys + -- TreeTarball !PackageTarball + deriving (Show, Eq) + +renderTree :: Tree -> ByteString +renderTree = BL.toStrict . toLazyByteString . go + where + go :: Tree -> Builder + go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m + + goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = + netstring (unSafeFilePath sfp) <> + byteString (SHA256.toRaw sha) <> + netword size' <> + (case ft of + FTNormal -> "N" + FTExecutable -> "X") + +netstring :: Text -> Builder +netstring t = + let bs = encodeUtf8 t + in netword (fromIntegral (B.length bs)) <> byteString bs + +netword :: Word -> Builder +netword w = wordDec w <> ":" + +parseTree :: ByteString -> Maybe Tree +parseTree bs1 = do + tree <- parseTree' bs1 + let bs2 = renderTree tree + guard $ bs1 == bs2 + Just tree + +parseTree' :: ByteString -> Maybe Tree +parseTree' bs0 = do + entriesBS <- B.stripPrefix "map:" bs0 + TreeMap <$> loop Map.empty entriesBS + where + loop !m bs1 + | B.null bs1 = pure m + | otherwise = do + (sfpBS, bs2) <- takeNetstring bs1 + sfp <- + case decodeUtf8' sfpBS of + Left _ -> Nothing + Right sfpT -> mkSafeFilePath sfpT + (sha, bs3) <- takeSha bs2 + (size', bs4) <- takeNetword bs3 + (typeW, bs5) <- B.uncons bs4 + ft <- + case typeW of + 78 -> Just FTNormal -- 'N' + 88 -> Just FTExecutable -- 'X' + _ -> Nothing + let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft + loop (Map.insert sfp entry m) bs5 + + takeNetstring bs1 = do + (size', bs2) <- takeNetword bs1 + guard $ B.length bs2 >= size' + Just $ B.splitAt size' bs2 + + takeSha bs = do + let (x, y) = B.splitAt 32 bs + x' <- either (const Nothing) Just (SHA256.fromRaw x) + Just (x', y) + + takeNetword = + go 0 + where + go !accum bs = do + (next, rest) <- B.uncons bs + if + | next == 58 -> pure (accum, rest) -- ':' + | next >= 48 && next <= 57 -> + go + (accum * 10 + fromIntegral (next - 48)) + rest + | otherwise -> Nothing + + {- +data PackageTarball = PackageTarball + { ptBlob :: !BlobKey + -- ^ Contains the tarball itself + , ptCabal :: !BlobKey + -- ^ Contains the cabal file contents + , ptSubdir :: !FilePath + -- ^ Subdir containing the files we want for this package. + -- + -- There must be precisely one file with a @.cabal@ file extension + -- located there. Thanks to Hackage revisions, its contents will be + -- overwritten by the value of @ptCabal@. + } + deriving Show + -} + +-- | This is almost a copy of Cabal's parser for package identifiers, +-- the main difference is in the fact that Stack requires version to be +-- present while Cabal uses "null version" as a defaul value +-- +-- @since 0.1.0.0 +parsePackageIdentifier :: String -> Maybe PackageIdentifier +parsePackageIdentifier str = + case [p | (p, s) <- Parse.readP_to_S parser str, all isSpace s] of + [] -> Nothing + (p:_) -> Just p + where + parser = do + n <- Distribution.Text.parse + -- version is a required component of a package identifier for Stack + v <- Parse.char '-' >> Distribution.Text.parse + return (PackageIdentifier n v) + +-- | Parse a package name from a 'String'. +-- +-- @since 0.1.0.0 +parsePackageName :: String -> Maybe PackageName +parsePackageName = Distribution.Text.simpleParse + +-- | Parse a package name from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parsePackageNameThrowing :: MonadThrow m => String -> m PackageName +parsePackageNameThrowing str = + case parsePackageName str of + Nothing -> throwM $ PackageNameParseFail $ T.pack str + Just pn -> pure pn + +-- | Parse a version from a 'String'. +-- +-- @since 0.1.0.0 +parseVersion :: String -> Maybe Version +parseVersion = Distribution.Text.simpleParse + +-- | Parse a package version from a 'String' throwing on failure +-- +-- @since 0.1.0.0 +parseVersionThrowing :: MonadThrow m => String -> m Version +parseVersionThrowing str = + case parseVersion str of + Nothing -> throwM $ PackageVersionParseFail $ T.pack str + Just v -> pure v + +-- | Parse a version range from a 'String'. +-- +-- @since 0.1.0.0 +parseVersionRange :: String -> Maybe VersionRange +parseVersionRange = Distribution.Text.simpleParse + +-- | Parse a module name from a 'String'. +-- +-- @since 0.1.0.0 +parseModuleName :: String -> Maybe ModuleName +parseModuleName = Distribution.Text.simpleParse + +-- | Parse a flag name from a 'String'. +-- +-- @since 0.1.0.0 +parseFlagName :: String -> Maybe FlagName +parseFlagName = Distribution.Text.simpleParse + +-- | Render a package name as a 'String'. +-- +-- @since 0.1.0.0 +packageNameString :: PackageName -> String +packageNameString = unPackageName + +-- | Render a package identifier as a 'String'. +-- +-- @since 0.1.0.0 +packageIdentifierString :: PackageIdentifier -> String +packageIdentifierString = Distribution.Text.display + +-- | Render a version as a 'String'. +-- +-- @since 0.1.0.0 +versionString :: Version -> String +versionString = Distribution.Text.display + +-- | Render a flag name as a 'String'. +-- +-- @since 0.1.0.0 +flagNameString :: FlagName -> String +flagNameString = unFlagName + +-- | Render a module name as a 'String'. +-- +-- @since 0.1.0.0 +moduleNameString :: ModuleName -> String +moduleNameString = Distribution.Text.display + +data OptionalSubdirs + = OSSubdirs !(NonEmpty Text) + | OSPackageMetadata !Text !RawPackageMetadata + -- ^ subdirectory and package metadata + deriving (Show, Eq, Generic) +instance NFData OptionalSubdirs + +-- | Metadata provided by a config file for archives and repos. This +-- information can be used for optimized lookups of information like +-- package identifiers, or for validating that the user configuration +-- has the expected information. +-- +-- @since 0.1.0.0 +data RawPackageMetadata = RawPackageMetadata + { rpmName :: !(Maybe PackageName) + -- ^ Package name in the cabal file + -- + -- @since 0.1.0.0 + , rpmVersion :: !(Maybe Version) + -- ^ Package version in the cabal file + -- + -- @since 0.1.0.0 + , rpmTreeKey :: !(Maybe TreeKey) + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + , rpmCabal :: !(Maybe BlobKey) + -- ^ Blob key containing the cabal file + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) +instance NFData RawPackageMetadata + +instance Display RawPackageMetadata where + display rpm = fold $ intersperse ", " $ catMaybes + [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm + , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm + , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm + , (\cabal -> "cabal file == " <> display cabal) <$> rpmCabal rpm + ] + +-- | Exact metadata specifying concrete package +-- +-- @since 0.1.0.0 +data PackageMetadata = PackageMetadata + { pmIdent :: !PackageIdentifier + -- ^ Package identifier in the cabal file + -- + -- @since 0.1.0.0 + , pmTreeKey :: !TreeKey + -- ^ Tree key of the loaded up package + -- + -- @since 0.1.0.0 + , pmCabal :: !BlobKey + -- ^ Blob key containing the cabal file + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Ord, Generic, Typeable) +-- i PackageMetadata +instance NFData PackageMetadata + +instance Display PackageMetadata where + display pm = fold $ intersperse ", " $ + [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) + , "tree == " <> display (pmTreeKey pm) + , "cabal file == " <> display (pmCabal pm) + ] + +parsePackageMetadata :: Object -> WarningParser PackageMetadata +parsePackageMetadata o = do + pmCabal :: BlobKey <- o ..: "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + +-- | Conver package metadata to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawPM :: PackageMetadata -> RawPackageMetadata +toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) (Just $ pmCabal pm) + where + PackageIdentifier name version = pmIdent pm + +-- | File path relative to the configuration file it was parsed from +-- +-- @since 0.1.0.0 +newtype RelFilePath = RelFilePath Text + deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) + +-- | Location that an archive is stored at +-- +-- @since 0.1.0.0 +data ArchiveLocation + = ALUrl !Text + -- ^ Archive stored at an HTTP(S) URL + -- + -- @since 0.1.0.0 + | ALFilePath !(ResolvedPath File) + -- ^ Archive stored at a local file path + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic, Typeable) +instance NFData ArchiveLocation + +instance Display ArchiveLocation where + display (ALUrl url) = display url + display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved + +parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) +parseArchiveLocationObject o = + ((o ..: "url") >>= validateUrl) <|> + ((o ..: "filepath") >>= validateFilePath) <|> + ((o ..: "archive") >>= parseArchiveLocationText) <|> + ((o ..: "location") >>= parseArchiveLocationText) + +-- Forgive me my father, for I have sinned (bad fail, bad!) +parseArchiveLocationText :: (Monad m, Alternative m) => Text -> m (Unresolved ArchiveLocation) +parseArchiveLocationText t = validateUrl t <|> validateFilePath t + +validateUrl :: Monad m => Text -> m (Unresolved ArchiveLocation) +validateUrl t = + case parseRequest $ T.unpack t of + Left _ -> fail $ "Could not parse URL: " ++ T.unpack t + Right _ -> pure $ pure $ ALUrl t + +validateFilePath :: Monad m => Text -> m (Unresolved ArchiveLocation) +validateFilePath t = + if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") + then pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir $ T.unpack t + pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' + else fail $ "Does not have an archive file extension: " ++ T.unpack t + +instance ToJSON RawPackageLocation where + toJSON (RPLImmutable rpli) = toJSON rpli + toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where + parseJSON v = + ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> + ((noJSONWarnings . mkMutable) <$> parseJSON v) + where + mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' + +instance ToJSON RawPackageLocationImmutable where + toJSON (RPLIHackage pir mtree) = object $ concat + [ ["hackage" .= pir] + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + ] + toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat + [ case loc of + ALUrl url -> ["url" .= url] + ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] + , maybe [] (\sha -> ["sha256" .= sha]) msha + , maybe [] (\size' -> ["size" .= size']) msize + , if T.null subdir then [] else ["subdir" .= subdir] + , rpmToPairs rpm + ] + toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat + [ [ urlKey .= url + , "commit" .= commit + ] + , if T.null subdir then [] else ["subdir" .= subdir] + , rpmToPairs rpm + ] + where + urlKey = + case typ of + RepoGit -> "git" + RepoHg -> "hg" + +rpmToPairs :: RawPackageMetadata -> [(Text, Value)] +rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat + [ maybe [] (\name -> ["name" .= CabalString name]) mname + , maybe [] (\version -> ["version" .= CabalString version]) mversion + , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree + , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal + ] + +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do + pm <- parsePackageMetadata o + repoSubdir <- o ..:? "subdir" ..!= "" + repoCommit <- o ..: "commit" + (repoType, repoUrl) <- + (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> + (o ..: "hg" >>= \url -> pure (RepoHg, url)) + pure $ pure $ PLIRepo Repo {..} pm + + archiveObject = + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do + pm <- parsePackageMetadata o + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + + hackageObject = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) + + github value = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + pm <- parsePackageMetadata o + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let archiveLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ pure $ PLIArchive Archive {..} pm) value + +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where + parseJSON v + = http v + <|> hackageText v + <|> hackageObject v + <|> repo v + <|> archiveObject v + <|> github v + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) + where + http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Nothing -> fail $ "Invalid archive location: " ++ T.unpack t + Just (Unresolved mkArchiveLocation) -> + pure $ noJSONWarnings $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + let raHash = Nothing + raSize = Nothing + raSubdir = T.empty + pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty + + hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing + + hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage + <$> o ..: "hackage" + <*> o ..:? "pantry-tree") + + optionalSubdirs :: Object -> WarningParser OptionalSubdirs + optionalSubdirs o = + -- if subdirs exists, it needs to be valid + case HM.lookup "subdirs" o of + Just v' -> do + tellJSONField "subdirs" + subdirs <- lift $ parseJSON v' + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> OSPackageMetadata + <$> o ..:? "subdir" ..!= T.empty + <*> (RawPackageMetadata + <$> (fmap unCabalString <$> (o ..:? "name")) + <*> (fmap unCabalString <$> (o ..:? "version")) + <*> o ..:? "pantry-tree" + <*> o ..:? "cabal-file") + + repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o ..: "git") <|> + ((RepoHg, ) <$> o ..: "hg") + repoCommit <- o ..: "commit" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + + archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + + github = withObjectWarnings "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let raLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raHash <- o ..:? "sha256" + raSize <- o ..:? "size" + os <- optionalSubdirs o + pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + +-- | Returns pairs of subdirectory and 'PackageMetadata'. +osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) +osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs +osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) + +rpmEmpty :: RawPackageMetadata +rpmEmpty = RawPackageMetadata Nothing Nothing Nothing Nothing + +-- | Newtype wrapper for easier JSON integration with Cabal types. +-- +-- @since 0.1.0.0 +newtype CabalString a = CabalString { unCabalString :: a } + deriving (Show, Eq, Ord, Typeable) + +-- I'd like to use coerce here, but can't due to roles. unsafeCoerce +-- could work, but let's avoid unsafe code. + +-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' +-- instance. +-- +-- @since 0.1.0.0 +toCabalStringMap :: Map a v -> Map (CabalString a) v +toCabalStringMap = Map.mapKeysMonotonic CabalString + +-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a +-- 'FromJSON' instance. +-- +-- @since 0.1.0.0 +unCabalStringMap :: Map (CabalString a) v -> Map a v +unCabalStringMap = Map.mapKeysMonotonic unCabalString + +instance Distribution.Text.Text a => ToJSON (CabalString a) where + toJSON = toJSON . Distribution.Text.display . unCabalString +instance Distribution.Text.Text a => ToJSONKey (CabalString a) where + toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString + +instance forall a. IsCabalString a => FromJSON (CabalString a) where + parseJSON = withText name $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) +instance forall a. IsCabalString a => FromJSONKey (CabalString a) where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case cabalStringParser $ T.unpack t of + Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t + Just x -> pure $ CabalString x + where + name = cabalStringName (Nothing :: Maybe a) + +class IsCabalString a where + cabalStringName :: proxy a -> String + cabalStringParser :: String -> Maybe a +instance IsCabalString PackageName where + cabalStringName _ = "package name" + cabalStringParser = parsePackageName +instance IsCabalString Version where + cabalStringName _ = "version" + cabalStringParser = parseVersion +instance IsCabalString VersionRange where + cabalStringName _ = "version range" + cabalStringParser = parseVersionRange +instance IsCabalString PackageIdentifier where + cabalStringName _ = "package identifier" + cabalStringParser = parsePackageIdentifier +instance IsCabalString FlagName where + cabalStringName _ = "flag name" + cabalStringParser = parseFlagName + +-- | What to use for running hpack +-- +-- @since 0.1.0.0 +data HpackExecutable + = HpackBundled + -- ^ Compiled in library + | HpackCommand !FilePath + -- ^ Executable at the provided path + deriving (Show, Read, Eq, Ord) + + +-- | Which compiler a snapshot wants to use. The build tool may elect +-- to do some fuzzy matching of versions (e.g., allowing different +-- patch versions). +-- +-- @since 0.1.0.0 +data WantedCompiler + = WCGhc !Version + | WCGhcGit !Text !Text + | WCGhcjs + !Version + !Version + -- ^ GHCJS version followed by GHC version + deriving (Show, Eq, Ord, Generic) + +instance NFData WantedCompiler +instance Display WantedCompiler where + display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) + display (WCGhcjs vghcjs vghc) = + "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) + display (WCGhcGit commit flavour) = + "ghc-git-" <> display commit <> "-" <> display flavour +instance ToJSON WantedCompiler where + toJSON = toJSON . utf8BuilderToText . display +instance FromJSON WantedCompiler where + parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler +instance FromJSONKey WantedCompiler where + fromJSONKey = + FromJSONKeyTextParser $ \t -> + case parseWantedCompiler t of + Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e + Right x -> pure x + +-- | Parse a 'Text' into a 'WantedCompiler' value. +-- +-- @since 0.1.0.0 +parseWantedCompiler :: Text -> Either PantryException WantedCompiler +parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ + case T.stripPrefix "ghcjs-" t0 of + Just t1 -> parseGhcjs t1 + Nothing -> case T.stripPrefix "ghc-git-" t0 of + Just t1 -> parseGhcGit t1 + Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc + where + parseGhcjs t1 = do + let (ghcjsVT, t2) = T.break (== '_') t1 + ghcjsV <- parseVersion $ T.unpack ghcjsVT + ghcVT <- T.stripPrefix "_ghc-" t2 + ghcV <- parseVersion $ T.unpack ghcVT + pure $ WCGhcjs ghcjsV ghcV + parseGhcGit t1 = do + let (commit, flavour) = T.break (== '-') t1 + pure $ WCGhcGit commit (T.drop 1 flavour) + parseGhc = fmap WCGhc . parseVersion . T.unpack + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where + parseJSON v = text v <|> obj v + where + text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation + + obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) + obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> + ((pure . RSLCompiler) <$> o ..: "compiler") <|> + ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> + (parseRawSnapshotLocationPath <$> o ..: "filepath") + + blobKey o = do + msha <- o ..:? "sha256" + msize <- o ..:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + +instance Display SnapshotLocation where + display (SLCompiler compiler) = display compiler + display (SLUrl url blob) = + fromMaybe (display url) (specialRawSnapshotLocation url) <> + " (" <> display blob <> ")" + display (SLFilePath resolved) = display (resolvedRelative resolved) + +-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. +-- +-- @since 0.1.0.0 +parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ + (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> + parseLts <|> + parseNightly <|> + parseGithub <|> + parseUrl + where + parseLts = do + t1 <- T.stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- T.stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + Just $ pure $ ltsSnapshotLocation x y + parseNightly = do + t1 <- T.stripPrefix "nightly-" t0 + date <- readMaybe (T.unpack t1) + Just $ pure $ nightlySnapshotLocation date + + parseGithub = do + t1 <- T.stripPrefix "github:" t0 + let (user, t2) = T.break (== '/') t1 + t3 <- T.stripPrefix "/" t2 + let (repo, t4) = T.break (== ':') t3 + path <- T.stripPrefix ":" t4 + Just $ pure $ githubSnapshotLocation user repo path + + parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) + +parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation +parseRawSnapshotLocationPath t = + Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) + pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' + +githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation +githubSnapshotLocation user repo path = + let url = T.concat + [ "https://raw.githubusercontent.com/" + , user + , "/" + , repo + , "/master/" + , path + ] + in RSLUrl url Nothing + +defUser :: Text +defUser = "commercialhaskell" + +defRepo :: Text +defRepo = "stackage-snapshots" + +-- | Location of an LTS snapshot +-- +-- @since 0.1.0.0 +ltsSnapshotLocation + :: Int -- ^ major version + -> Int -- ^ minor version + -> RawSnapshotLocation +ltsSnapshotLocation x y = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "lts/" <> display x <> "/" <> display y <> ".yaml" + +-- | Location of a Stackage Nightly snapshot +-- +-- @since 0.1.0.0 +nightlySnapshotLocation :: Day -> RawSnapshotLocation +nightlySnapshotLocation date = + githubSnapshotLocation defUser defRepo $ + utf8BuilderToText $ + "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" + where + (year, month, day) = toGregorian date + +-- | Where to load a snapshot from in raw form +-- (RSUrl could have a missing BlobKey) +-- +-- @since 0.1.0.0 +data RawSnapshotLocation + = RSLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | RSLUrl !Text !(Maybe BlobKey) + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | RSLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic) + +instance NFData RawSnapshotLocation + +instance Display RawSnapshotLocation where + display (RSLCompiler compiler) = display compiler + display (RSLUrl url Nothing) = fromMaybe (display url) $ specialRawSnapshotLocation url + display (RSLUrl url (Just blob)) = + fromMaybe (display url) (specialRawSnapshotLocation url) <> + " (" <> display blob <> ")" + display (RSLFilePath resolved) = display (resolvedRelative resolved) + +-- | For nicer display purposes: present a 'RawSnapshotLocation' as a +-- short form like lts-13.13 if possible. +specialRawSnapshotLocation :: Text -> Maybe Utf8Builder +specialRawSnapshotLocation url = do + t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" url + parseLTS t1 <|> parseNightly t1 + where + popInt :: Text -> Maybe (Int, Text) + popInt t0 = + -- Would be nice if this function did overflow checking for us + case decimal t0 of + Left _ -> Nothing + Right (x, rest) -> (, rest) <$> do + if (x :: Integer) > fromIntegral (maxBound :: Int) + then Nothing + else Just (fromIntegral x) + + parseLTS t1 = do + t2 <- T.stripPrefix "lts/" t1 + (major, t3) <- popInt t2 + (minor, ".yaml") <- T.stripPrefix "/" t3 >>= popInt + Just $ "lts-" <> display major <> "." <> display minor + parseNightly t1 = do + t2 <- T.stripPrefix "nightly/" t1 + (year, t3) <- popInt t2 + (month, t4) <- T.stripPrefix "/" t3 >>= popInt + (day, ".yaml") <- T.stripPrefix "/" t4 >>= popInt + date <- fromGregorianValid (fromIntegral year) month day + Just $ "nightly-" <> displayShow date + +instance ToJSON RawSnapshotLocation where + toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] + toJSON (RSLUrl url Nothing) + | Just x <- specialRawSnapshotLocation url = String $ utf8BuilderToText x + toJSON (RSLUrl url mblob) = object + $ "url" .= url + : maybe [] blobKeyPairs mblob + toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] + +-- | Where to load a snapshot from. +-- +-- @since 0.1.0.0 +data SnapshotLocation + = SLCompiler !WantedCompiler + -- ^ Don't use an actual snapshot, just a version of the compiler + -- with its shipped packages. + -- + -- @since 0.1.0.0 + | SLUrl !Text !BlobKey + -- ^ Download the snapshot from the given URL. The optional + -- 'BlobKey' is used for reproducibility. + -- + -- @since 0.1.0.0 + | SLFilePath !(ResolvedPath File) + -- ^ Snapshot at a local file path. + -- + -- @since 0.1.0.0 + deriving (Show, Eq, Ord, Generic) +instance NFData SnapshotLocation + +instance ToJSON SnapshotLocation where + toJSON sl = toJSON (toRawSL sl) + +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ SLFilePath fp + url = withObjectWarnings "SLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha256" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "SLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ SLCompiler c + +-- | Convert snapshot location to its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSL :: SnapshotLocation -> RawSnapshotLocation +toRawSL (SLCompiler c) = RSLCompiler c +toRawSL (SLUrl url blob) = RSLUrl url (Just blob) +toRawSL (SLFilePath fp) = RSLFilePath fp + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshot = RawSnapshot + { rsCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , rsPackages :: !(Map PackageName RawSnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , rsDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | A flattened representation of all the layers in a snapshot. +-- +-- @since 0.1.0.0 +data Snapshot = Snapshot + { snapshotCompiler :: !WantedCompiler + -- ^ The compiler wanted for this snapshot. + , snapshotPackages :: !(Map PackageName SnapshotPackage) + -- ^ Packages available in this snapshot for installation. This will be + -- applied on top of any globally available packages. + , snapshotDrop :: !(Set PackageName) + -- ^ Global packages that should be dropped/ignored. + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data RawSnapshotPackage = RawSnapshotPackage + { rspLocation :: !RawPackageLocationImmutable + -- ^ Where to get the package from + , rspFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , rspHidden :: !Bool + -- ^ Same as 'slHidden' + , rspGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + +-- | Settings for a package found in a snapshot. +-- +-- @since 0.1.0.0 +data SnapshotPackage = SnapshotPackage + { spLocation :: !PackageLocationImmutable + -- ^ Where to get the package from + , spFlags :: !(Map FlagName Bool) + -- ^ Same as 'slFlags' + , spHidden :: !Bool + -- ^ Same as 'slHidden' + , spGhcOptions :: ![Text] + -- ^ Same as 'slGhcOptions' + } + deriving Show + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data RawSnapshotLayer = RawSnapshotLayer + { rslParent :: !RawSnapshotLocation + -- ^ The sl to extend from. This is either a specific + -- compiler, or a @SnapshotLocation@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + -- + -- @since 0.1.0.0 + , rslCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be + -- 'Nothing' if using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , rslLocations :: ![RawPackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , rslDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + -- + -- @since 0.1.0.0 + , rslFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , rslHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , rslGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , rslPublishTime :: !(Maybe UTCTime) + -- ^ See 'slPublishTime' + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance NFData RawSnapshotLayer + +instance ToJSON RawSnapshotLayer where + toJSON rsnap = object $ concat + [ ["resolver" .= rslParent rsnap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) + , ["packages" .= rslLocations rsnap] + , if Set.null (rslDropPackages rsnap) + then [] + else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] + , if Map.null (rslFlags rsnap) + then [] + else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] + , if Map.null (rslHidden rsnap) + then [] + else ["hidden" .= toCabalStringMap (rslHidden rsnap)] + , if Map.null (rslGhcOptions rsnap) + then [] + else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] + , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) + ] + +instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where + parseJSON = withObjectWarnings "Snapshot" $ \o -> do + _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format + mcompiler <- o ..:? "compiler" + mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) + (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure (sl, mcompiler) + + unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) + rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) + rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) + rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) + rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) + rslPublishTime <- o ..:? "publish-time" + pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) + <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) + <*> unresolvedSnapshotParent + +-- | A single layer of a snapshot, i.e. a specific YAML configuration file. +-- +-- @since 0.1.0.0 +data SnapshotLayer = SnapshotLayer + { slParent :: !SnapshotLocation + -- ^ The sl to extend from. This is either a specific + -- compiler, or a @SnapshotLocation@ which gives us more information + -- (like packages). Ultimately, we'll end up with a + -- @CompilerVersion@. + -- + -- @since 0.1.0.0 + , slCompiler :: !(Maybe WantedCompiler) + -- ^ Override the compiler specified in 'slParent'. Must be + -- 'Nothing' if using 'SLCompiler'. + -- + -- @since 0.1.0.0 + , slLocations :: ![PackageLocationImmutable] + -- ^ Where to grab all of the packages from. + -- + -- @since 0.1.0.0 + , slDropPackages :: !(Set PackageName) + -- ^ Packages present in the parent which should not be included + -- here. + -- + -- @since 0.1.0.0 + , slFlags :: !(Map PackageName (Map FlagName Bool)) + -- ^ Flag values to override from the defaults + -- + -- @since 0.1.0.0 + , slHidden :: !(Map PackageName Bool) + -- ^ Packages which should be hidden when registering. This will + -- affect, for example, the import parser in the script + -- command. We use a 'Map' instead of just a 'Set' to allow + -- overriding the hidden settings in a parent sl. + -- + -- @since 0.1.0.0 + , slGhcOptions :: !(Map PackageName [Text]) + -- ^ GHC options per package + -- + -- @since 0.1.0.0 + , slPublishTime :: !(Maybe UTCTime) + -- ^ Publication timestamp for this snapshot. This field is optional, and + -- is for informational purposes only. + -- + -- @since 0.1.0.0 + } + deriving (Show, Eq, Generic) + +instance ToJSON SnapshotLayer where + toJSON snap = object $ concat + [ ["resolver" .= slParent snap] + , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) + , ["packages" .= slLocations snap] + , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] + , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] + , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] + , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] + , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) + ] + +-- | Convert snapshot layer into its "raw" equivalent. +-- +-- @since 0.1.0.0 +toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer +toRawSnapshotLayer sl = RawSnapshotLayer + { rslParent = toRawSL (slParent sl) + , rslCompiler = slCompiler sl + , rslLocations = map toRawPLI (slLocations sl) + , rslDropPackages = slDropPackages sl + , rslFlags = slFlags sl + , rslHidden = slHidden sl + , rslGhcOptions = slGhcOptions sl + , rslPublishTime = slPublishTime sl + } + +-- | An arbitrary hash for a snapshot, used for finding module names +-- in a snapshot. Mostly intended for Stack's usage. +-- +-- @since 0.1.0.0 +newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} + deriving (Show) + +-- | Get the path to the global hints cache file +getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) +getGlobalHintsFile = do + root <- view $ pantryConfigL.to pcRootDir + globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" + pure $ root globalHintsRelFile + +-- | Creates BlobKey for an input ByteString +-- +-- @since 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) diff --git a/src/unix/System/IsWindows.hs b/src/unix/System/IsWindows.hs new file mode 100644 --- /dev/null +++ b/src/unix/System/IsWindows.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module System.IsWindows + ( osIsWindows + ) where + +import RIO (Bool (..)) + +-- | False if not using Windows OS. +osIsWindows :: Bool +osIsWindows = False diff --git a/src/windows/System/IsWindows.hs b/src/windows/System/IsWindows.hs new file mode 100644 --- /dev/null +++ b/src/windows/System/IsWindows.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module System.IsWindows + ( osIsWindows + ) where + +import RIO (Bool (..)) + +-- | True if using Windows OS. +osIsWindows :: Bool +osIsWindows = True diff --git a/test/Pantry/ArchiveSpec.hs b/test/Pantry/ArchiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/ArchiveSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Pantry.ArchiveSpec (spec) where + +import Test.Hspec +import Data.Maybe (fromJust) +import RIO +import RIO.Text as T +import Pantry +import Path.IO (resolveFile') + +data TestLocation + = TLFilePath String + | TLUrl Text + +data TestArchive = TestArchive + { testLocation :: !TestLocation + , testSubdir :: !Text + } + +getRawPackageLocationIdent' :: TestArchive -> IO PackageIdentifier +getRawPackageLocationIdent' TestArchive{..} = do + testLocation' <- case testLocation of + TLFilePath relPath -> do + absPath <- resolveFile' relPath + return $ ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ fromString relPath + , resolvedAbsolute = absPath + } + TLUrl url -> return $ ALUrl url + let archive = RawArchive + { raLocation = testLocation' + , raHash = Nothing + , raSize = Nothing + , raSubdir = testSubdir + } + runPantryApp $ getRawPackageLocationIdent $ RPLIArchive archive metadata + where + metadata = RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + +parsePackageIdentifier' :: String -> PackageIdentifier +parsePackageIdentifier' = fromJust . parsePackageIdentifier + +urlToStackCommit :: Text -> TestLocation +urlToStackCommit commit = TLUrl $ T.concat + [ "https://github.com/commercialhaskell/stack/archive/" + , commit + , ".tar.gz" + ] + +treeWithoutCabalFile :: Selector PantryException +treeWithoutCabalFile (TreeWithoutCabalFile _) = True +treeWithoutCabalFile _ = False + +spec :: Spec +spec = do + it "finds cabal file from tarball" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "" + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with subdir '.'" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "." + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with a package.yaml" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" + , testSubdir = "" + } + ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" + it "finds cabal file from tarball with subdir '.' with a package.yaml" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/hpack-0.1.2.3.tar.gz" + , testSubdir = "." + } + ident `shouldBe` parsePackageIdentifier' "hpack-0.1.2.3" + it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pantry/" + } + ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" + it "matches whole directory name" $ + getRawPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pant" + } + `shouldThrow` treeWithoutCabalFile + it "follows symlinks to directories" $ do + ident <- getRawPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/symlink-to-dir.tar.gz" + , testSubdir = "symlink" + } + ident `shouldBe` parsePackageIdentifier' "foo-1.2.3" diff --git a/test/Pantry/BuildPlanSpec.hs b/test/Pantry/BuildPlanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/BuildPlanSpec.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Pantry.BuildPlanSpec where + +import Pantry.Internal.AesonExtended (WithJSONWarnings(..)) +import RIO +import qualified Data.ByteString.Char8 as S8 +import Data.Yaml (decodeThrow) +import Pantry +import Test.Hspec +import Control.Monad.Catch (MonadThrow) +import Data.List.NonEmpty (NonEmpty) + +spec :: Spec +spec = + describe "PackageLocation" $ do + describe "Archive" $ do + describe "github" $ do + let decode' :: (HasCallStack, MonadThrow m) => ByteString -> m (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) + decode' = decodeThrow + + decode'' :: HasCallStack => ByteString -> IO (NonEmpty RawPackageLocationImmutable) + decode'' bs = do + WithJSONWarnings unresolved warnings <- decode' bs + unless (null warnings) $ error $ show warnings + resolvePaths Nothing unresolved + + it "'github' and 'commit' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + ]) + let expected :: RawPackageLocationImmutable + expected = + RPLIArchive + RawArchive + { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , raHash = Nothing + , raSize = Nothing + , raSubdir = "" + } + RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + actual <- decode'' contents + actual `shouldBe` pure expected + + it "'github', 'commit', and 'subdirs' keys" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town" + , "commit: abc123" + , "subdirs:" + , " - foo" + ]) + let expected :: RawPackageLocationImmutable + expected = + RPLIArchive + RawArchive + { raLocation = ALUrl "https://github.com/oink/town/archive/abc123.tar.gz" + , raHash = Nothing + , raSize = Nothing + , raSubdir = "foo" + } + RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + actual <- decode'' contents + actual `shouldBe` pure expected + + it "does not parse GitHub repo with no slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink" + , "commit: abc123" + ]) + void (decode' contents) `shouldBe` Nothing + + it "does not parse GitHub repo with leading slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: /oink" + , "commit: abc123" + ]) + void (decode' contents) `shouldBe` Nothing + + it "does not parse GitHub repo with trailing slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/" + , "commit: abc123" + ]) + void (decode' contents) `shouldBe` Nothing + + it "does not parse GitHub repo with more than one slash" $ do + let contents :: ByteString + contents = + S8.pack + (unlines + [ "github: oink/town/here" + , "commit: abc123" + ]) + void (decode' contents) `shouldBe` Nothing diff --git a/test/Pantry/CabalSpec.hs b/test/Pantry/CabalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/CabalSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.CabalSpec (spec) where + +import Test.Hspec +import Pantry +import qualified Pantry.SHA256 as SHA256 +import RIO +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) + +spec :: Spec +spec = describe "wrong cabal file" $ do + let test name action = it name (runPantryApp action :: IO ()) + shouldThrow' x y = withRunInIO $ \run -> run x `shouldThrow` y + test "Hackage" $ do + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + let rpli = + RPLIHackage + (PackageIdentifierRevision + name + version3 + (CFIHash sha (Just size))) + Nothing + go = loadCabalFileRawImmutable rpli + name = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + version3 = mkVersion [0, 3] + size = FileSize 597 + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm _tree cabal ident -> + rpli == rpli' && + rpm == RawPackageMetadata + { rpmName = Just name + , rpmVersion = Just version3 + , rpmTreeKey = Nothing + , rpmCabal = Just $ BlobKey sha size + } && + cabal == BlobKey sha size && + ident == PackageIdentifier name version2 + _ -> False + + test "tarball with wrong ident" $ do + archiveHash' <- either throwIO pure + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + let rpli = RPLIArchive archive rpm + archive = + RawArchive + { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , raHash = Just archiveHash' + , raSize = Just $ FileSize 309199 + , raSubdir = "yesod-auth" + } + rpm = + RawPackageMetadata + { rpmName = Just acmeMissiles + , rpmVersion = Just version2 + , rpmCabal = Just $ BlobKey sha (FileSize 597) + , rpmTreeKey = Nothing + } + go = loadCabalFileRawImmutable rpli + acmeMissiles = mkPackageName "acme-missiles" + version2 = mkVersion [0, 2] + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident -> + rpli == rpli' && + rpm == rpm' && + cabal == BlobKey + (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (FileSize 3038) && + ident == PackageIdentifier + (mkPackageName "yesod-auth") + (mkVersion [1, 6, 4, 1]) + _ -> False + + test "tarball with wrong cabal file" $ do + sha <- either throwIO pure + $ SHA256.fromHexBytes "71c2c685a932cd3a70ec52d7bd0ec96ecbfa5e31e22130099cd50fa073ad1a69" + let rpli = RPLIArchive archive rpm + archive = + RawArchive + { raLocation = ALUrl "https://github.com/yesodweb/yesod/archive/yesod-auth-1.6.4.1.tar.gz" + , raHash = either impureThrow Just + $ SHA256.fromHexBytes "b5a582209c50e4a61e4b6c0fb91a6a7d65177a881225438b0144719bc3682c3a" + , raSize = Just $ FileSize 309199 + , raSubdir = "yesod-auth" + } + rpm = + RawPackageMetadata + { rpmName = Just yesodAuth + , rpmVersion = Just version + , rpmCabal = Just $ BlobKey sha (FileSize 597) + , rpmTreeKey = Nothing + } + go = loadCabalFileRawImmutable rpli + yesodAuth = mkPackageName "yesod-auth" + version = mkVersion [1, 6, 4, 1] + go `shouldThrow'` \e -> + case e of + MismatchedPackageMetadata rpli' rpm' _treeKey cabal ident -> + rpli == rpli' && + rpm == rpm' && + cabal == BlobKey + (either impureThrow id $ SHA256.fromHexBytes "940d82426ad1db0fcc978c0f386ac5d06df019546071993cb7c6633f1ad17d50") + (FileSize 3038) && + ident == PackageIdentifier yesodAuth version + _ -> False diff --git a/test/Pantry/FileSpec.hs b/test/Pantry/FileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/FileSpec.hs @@ -0,0 +1,18 @@ +module Pantry.FileSpec (spec) where + +import Test.Hspec +import Pantry +import Path +import Path.IO +import Control.Monad (void) + +spec :: Spec +spec = describe "loadCabalFilePath" $ do + it "sanity" $ do + abs' <- resolveDir' "." + (f, name, cabalfp) <- runPantryApp $ loadCabalFilePath abs' + suffix <- parseRelFile "pantry.cabal" + cabalfp `shouldBe` abs' suffix + name' <- parsePackageNameThrowing "pantry" + name `shouldBe` name' + void $ f NoPrintWarnings diff --git a/test/Pantry/GlobalHintsSpec.hs b/test/Pantry/GlobalHintsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/GlobalHintsSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.GlobalHintsSpec (spec) where + +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Version (mkVersion) +import RIO +import Pantry (loadGlobalHints, WantedCompiler (..), runPantryAppClean) +import Pantry.Internal +import Test.Hspec +import qualified RIO.Map as Map +import Path (toFilePath) + +spec :: Spec +spec = do + let it' name inner = it name $ example $ runPantryAppClean $ do + file <- getGlobalHintsFile + writeFileBinary (toFilePath file) "this should be ignored" + inner + it' "unknown compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [0, 0, 0, 0, 0, 0, 0]) + liftIO $ mmap `shouldBe` Nothing + it' "known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [8, 4, 3]) + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [8, 4, 3]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 11, 1, 0]) + Map.lookup (mkPackageName "bytestring") m `shouldBe` Just (mkVersion [0, 10, 8, 2]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing + it' "older known compiler" $ do + mmap <- loadGlobalHints $ WCGhc (mkVersion [7, 8, 4]) + case mmap of + Nothing -> error "not found" + Just m -> liftIO $ do + Map.lookup (mkPackageName "ghc") m `shouldBe` Just (mkVersion [7, 8, 4]) + Map.lookup (mkPackageName "base") m `shouldBe` Just (mkVersion [4, 7, 0, 2]) + Map.lookup (mkPackageName "Cabal") m `shouldBe` Just (mkVersion [1, 18, 1, 5]) + Map.lookup (mkPackageName "acme-missiles") m `shouldBe` Nothing diff --git a/test/Pantry/HackageSpec.hs b/test/Pantry/HackageSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/HackageSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.HackageSpec (spec) where + +import Test.Hspec +import Pantry +import RIO +import Distribution.Types.Version (mkVersion) + +spec :: Spec +spec = do + it "update works" $ asIO $ void $ runPantryApp $ updateHackageIndex Nothing + it "fuzzy lookup kicks in" $ do + let pir = PackageIdentifierRevision "thisisnot-tobe-foundon-hackage-please" (mkVersion [1..3]) CFILatest + runPantryApp (loadPackageRaw (RPLIHackage pir Nothing)) + `shouldThrow` \e -> + case e of + UnknownHackagePackage pir' _ -> pir == pir' + _ -> False + -- Flaky test, can be broken by new packages on Hackage. + it "finds acme-missiles" $ do + x <- runPantryApp (getHackageTypoCorrections "acme-missile") + x `shouldSatisfy` ("acme-missiles" `elem`) diff --git a/test/Pantry/Internal/StaticBytesSpec.hs b/test/Pantry/Internal/StaticBytesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/Internal/StaticBytesSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Pantry.Internal.StaticBytesSpec (spec) where + +import RIO +import Pantry.Internal.StaticBytes +import Control.Monad (replicateM) +import qualified Data.ByteString as B +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +spec :: Spec +spec = do + describe "ByteString" $ tests B.pack + describe "Storable Vector" $ tests VS.fromList + describe "Unboxed Vector" $ tests VU.fromList + describe "Primitive Vector" $ tests VP.fromList + +tests :: (Eq dbytes, Show dbytes, DynamicBytes dbytes) => ([Word8] -> dbytes) -> Spec +tests pack = do + it "disallows 4 bytes" $ property $ \(w1,w2,w3,w4) -> + toStaticExact (pack [w1,w2,w3,w4]) `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes8) + it "toStaticExact matches ByteString" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] + (expected :: Bytes8) = either impureThrow id $ toStaticExact (B.pack octets) + actual = either impureThrow id $ toStaticExact (pack octets) + actual `shouldBe` expected + + it "fromStatic round trips" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let octets = [w1,w2,w3,w4,w5,w6,w7,w8] + v1 = pack octets + (b8 :: Bytes8) = either impureThrow id $ toStaticExact v1 + v2 = fromStatic b8 + v2 `shouldBe` v1 + + it "allows 8 bytes" $ property $ \(w1,w2,w3,w4) -> property $ \(w5,w6,w7,w8) -> do + let bs = pack [w1,w2,w3,w4,w5,w6,w7,w8] + case toStaticExact bs of + Left e -> throwIO e + Right b8 -> fromStatic (b8 :: Bytes8) `shouldBe` bs + toStaticExact bs `shouldBe` (Left NotEnoughBytes :: Either StaticBytesException Bytes16) + it "padding is the same as trailing nulls" $ property $ \(w1,w2,w3,w4) -> do + let ws = [w1,w2,w3,w4] + bs1 = pack $ ws ++ replicate 4 0 + bs2 = pack ws + Right (toStaticPadTruncate bs2 :: Bytes8) `shouldBe` toStaticExact bs1 + + prop "handles bytes16" $ \octets -> do + let bs = pack $ take 16 octets + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack (take 16 (octets ++ replicate 16 0)) + + it "spot check bytes16" $ forAll (replicateM 16 arbitrary) $ \ws -> do + let bs = pack ws + (b16 :: Bytes16) = either impureThrow id $ toStaticPad bs + fromStatic b16 `shouldBe` pack ws + + prop "handles bytes32" $ \octets -> do + let bs = pack $ take 32 octets + (b32 :: Bytes32) = either impureThrow id $ toStaticPad bs + fromStatic b32 `shouldBe` pack (take 32 (take 32 octets ++ replicate 32 0)) + + prop "fuzz with encodeUtf8" $ \chars -> do + let t = T.pack $ filter (/= '\0') chars + bs = TE.encodeUtf8 t + bs128 = pack $ B.unpack $ B.take 128 $ bs `B.append` B.replicate 128 0 + b128 = toStaticPadTruncate (pack $ B.unpack bs) :: Bytes128 + + fromStatic b128 `shouldBe` bs128 diff --git a/test/Pantry/InternalSpec.hs b/test/Pantry/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/InternalSpec.hs @@ -0,0 +1,73 @@ +module Pantry.InternalSpec (spec) where + +import Test.Hspec +import Pantry (runPantryApp) +import Pantry.Internal (normalizeParents, makeTarRelative, hpackVersion) + +spec :: Spec +spec = do + describe "normalizeParents" $ do + let (!) :: HasCallStack => String -> Maybe String -> Spec + input ! output = + it input $ + let x = normalizeParents input + y = either (const Nothing) Just x + in y `shouldBe` output + + "/file/\\test" ! Nothing + "file/\\test" ! Just "file/\\test" + "/file/////\\test" ! Nothing + "file/////\\test" ! Just "file/\\test" + "file/test/" ! Just "file/test" + "/file/\\test////" ! Nothing + "/file/./test" ! Nothing + "file/./test" ! Just "file/test" + "/test/file/../bob/fred/" ! Nothing + "/test/file/../bob/fred" ! Nothing + "test/file/../bob/fred/" ! Just "test/bob/fred" + "test/file/../bob/fred" ! Just "test/bob/fred" + "../bob/fred" ! Nothing + "../bob/fred/" ! Nothing + "./bob/fred/" ! Just "bob/fred" + "./bob/fred" ! Just "bob/fred" + "./" ! Nothing + "./." ! Nothing + "/./" ! Nothing + "/" ! Nothing + "bob/fred/." ! Nothing + "//home" ! Nothing + "foobarbaz\\bin" ! Just "foobarbaz\\bin" + + describe "makeTarRelative" $ do + let test :: HasCallStack => FilePath -> FilePath -> Maybe FilePath -> Spec + test base rel expected = + it (show (base, rel)) $ + either (const Nothing) Just (makeTarRelative base rel) + `shouldBe` expected + + test "foo/bar" "baz" $ Just "foo/baz" + test "foo" "bar" $ Just "bar" + test "foo" "/bar" Nothing + test "foo/" "bar" Nothing + + -- MSS 2018-08-23: Arguable whether this should be Nothing + -- instead, since we don't want any absolute paths. However, + -- that's really a concern for normalizeParents. Point being: if + -- you refactor in the future, and this turns into Nothing, that's + -- fine. + test "/foo" "bar" $ Just "/bar" + + describe "Parse HPack version" $ do + {- + let isVersion :: Version -> Bool + isVersion _ = True + -} + + it "Shipped hpack version" $ example $ do + _version <- runPantryApp hpackVersion + -- version `shouldSatisfy` isVersion + pure () + + -- it "External hpack version" $ do + -- version <- runPantryApp $ customHpack "/home/sibi/.local/bin/hpack" hpackVersion + -- version `shouldSatisfy` isVersion diff --git a/test/Pantry/TreeSpec.hs b/test/Pantry/TreeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/TreeSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Pantry.TreeSpec (spec) where + +import Test.Hspec +import RIO +import Pantry + +spec :: Spec +spec = do + let tarURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.tar.gz" + zipURL = "https://github.com/snoyberg/file-embed/archive/47b499c3c58ca465c56ee0295d0a76782a66751d.zip" + emptyPM = RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + mkArchive url = + RPLIArchive + RawArchive + { raLocation = ALUrl url + , raHash = Nothing + , raSize = Nothing + , raSubdir = "" + } + emptyPM + tarPL = mkArchive tarURL + zipPL = mkArchive zipURL + gitPL = + RPLIRepo + Repo + { repoUrl = "https://github.com/snoyberg/file-embed.git" + , repoCommit = "47b499c3c58ca465c56ee0295d0a76782a66751d" + , repoType = RepoGit + , repoSubdir = "" + } + emptyPM + hgPL = + RPLIRepo + Repo + { repoUrl = "https://bitbucket.org/snoyberg/file-embed" + , repoCommit = "6d8126e7a4821788a0275fa7c2c4a0083e14d690" + , repoType = RepoHg + , repoSubdir = "" + } + emptyPM + + it "zip and tar.gz archives match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw zipPL + liftIO $ pair2 `shouldBe` pair1 + it "archive and Git repo match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw gitPL + liftIO $ pair2 `shouldBe` pair1 + it "archive and Hg repo match" $ asIO $ runPantryAppClean $ do + pair1 <- loadPackageRaw tarPL + pair2 <- loadPackageRaw hgPL + liftIO $ pair2 `shouldBe` pair1 diff --git a/test/Pantry/TypesSpec.hs b/test/Pantry/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Pantry/TypesSpec.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Pantry.TypesSpec + ( spec + ) where + +import Pantry.Internal.AesonExtended +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Pantry +import Pantry.Internal + ( Tree(..) + , TreeEntry(..) + , mkSafeFilePath + , parseTree + , renderTree + ) +import qualified Pantry.SHA256 as SHA256 +import RIO +import qualified RIO.Text as T +import Test.Hspec +import Text.RawString.QQ +import RIO.Time (Day (..)) + +hh :: HasCallStack => String -> Property -> Spec +hh name p = it name $ do + result <- check p + unless result $ throwString "Hedgehog property failed" :: IO () + +genBlobKey :: Gen BlobKey +genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) + +genSha256 :: Gen SHA256 +genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) + +samplePLIRepo :: ByteString +samplePLIRepo = + [r| +subdir: wai +cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 +name: wai +version: 3.2.1.2 +git: https://github.com/yesodweb/wai.git +pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 +commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +|] + +samplePLIRepo2 :: ByteString +samplePLIRepo2 = + [r| +cabal-file: + size: 1863 + sha256: 5ebffc39e75ea1016adcc8426dc31d2040d2cc8a5f4bbce228592ef35e233da2 +name: merkle-log +version: 0.1.0.0 +git: https://github.com/kadena-io/merkle-log.git +pantry-tree: + size: 615 + sha256: 5a99e5e41ccd675a7721a733714ba2096f4204d9010f867c5fb7095b78e2959d +commit: a7ae61d7082afe3aa1a0fd0546fc1351a2f7c376 +|] + +spec :: Spec +spec = do + describe "WantedCompiler" $ do + hh "parse/render works" $ property $ do + wc <- forAll $ + let ghc = WCGhc <$> genVersion + ghcjs = WCGhcjs <$> genVersion <*> genVersion + genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) + in Gen.choice [ghc, ghcjs] + let text = utf8BuilderToText $ display wc + case parseWantedCompiler text of + Left e -> throwIO e + Right actual -> liftIO $ actual `shouldBe` wc + + describe "Tree" $ do + hh "parse/render works" $ property $ do + tree <- forAll $ + let sfp = do + pieces <- Gen.list (Range.linear 1 10) sfpComponent + let combined = T.intercalate "/" pieces + case mkSafeFilePath combined of + Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces + Just sfp' -> pure sfp' + sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum + entry = TreeEntry + <$> genBlobKey + <*> Gen.choice (map pure [minBound..maxBound]) + in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) + let bs = renderTree tree + liftIO $ parseTree bs `shouldBe` Just tree + + describe "(Raw)SnapshotLayer" $ do + let parseSl :: String -> IO RawSnapshotLayer + parseSl str = case Yaml.decodeThrow . S8.pack $ str of + (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x + Nothing -> fail "Can't parse RawSnapshotLayer" + + it "parses snapshot using 'resolver'" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "resolver: lts-2.10\n" + rslParent `shouldBe` ltsSnapshotLocation 2 10 + + it "parses snapshot using 'snapshot'" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "snapshot: lts-2.10\n" + rslParent `shouldBe` ltsSnapshotLocation 2 10 + + it "throws if both 'resolver' and 'snapshot' are present" $ do + let go = parseSl $ + "name: 'test'\n" ++ + "resolver: lts-2.10\n" ++ + "snapshot: lts-2.10\n" + go `shouldThrow` anyException + + it "throws if both 'snapshot' and 'compiler' are not present" $ do + let go = parseSl "name: 'test'\n" + go `shouldThrow` anyException + + it "works if no 'snapshot' specified" $ do + RawSnapshotLayer{..} <- parseSl $ + "name: 'test'\n" ++ + "compiler: ghc-8.0.1\n" + rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) + + hh "rendering an LTS gives a nice name" $ property $ do + (major, minor) <- forAll $ (,) + <$> Gen.integral (Range.linear 1 10000) + <*> Gen.integral (Range.linear 1 10000) + liftIO $ + Yaml.toJSON (ltsSnapshotLocation major minor) `shouldBe` + Yaml.String (T.pack $ concat ["lts-", show major, ".", show minor]) + + hh "rendering a nightly gives a nice name" $ property $ do + days <- forAll $ Gen.integral $ Range.linear 1 10000000 + let day = ModifiedJulianDay days + liftIO $ + Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` + Yaml.String (T.pack $ "nightly-" ++ show day) + it "FromJSON instance for PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + let repoValue = + Repo + { repoSubdir = "wai" + , repoType = RepoGit + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoUrl = "https://github.com/yesodweb/wai.git" + } + cabalSha = + SHA256.fromHexBytes + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + pantrySha = + SHA256.fromHexBytes + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" + (csha, psha) <- case (cabalSha, pantrySha) of + (Right csha, Right psha) -> pure (csha, psha) + _ -> fail "Failed decoding sha256" + let pkgValue = + PackageMetadata + { pmIdent = + PackageIdentifier + (mkPackageName "wai") + (mkVersion [3, 2, 1, 2]) + , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) + , pmCabal = BlobKey csha (FileSize 1765) + } + pli `shouldBe` PLIRepo repoValue pkgValue + + WithJSONWarnings reparsed warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + reparsed' <- resolvePaths Nothing reparsed + reparsed' `shouldBe` pli + it "parseHackageText parses" $ do + let txt = + "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" + hsha = + SHA256.fromHexBytes + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" + sha <- case hsha of + Right sha' -> pure sha' + _ -> fail "parseHackagetext: failed decoding the sha256" + let Right (pkgIdentifier, blobKey) = parseHackageText txt + blobKey `shouldBe` (BlobKey sha (FileSize 5058)) + pkgIdentifier `shouldBe` + PackageIdentifier + (mkPackageName "persistent") + (mkVersion [2, 8, 2]) + it "roundtripping a PLIRepo" $ do + WithJSONWarnings unresolvedPli warnings <- Yaml.decodeThrow samplePLIRepo2 + warnings `shouldBe` [] + pli <- resolvePaths Nothing unresolvedPli + WithJSONWarnings unresolvedPli2 warnings2 <- Yaml.decodeThrow $ Yaml.encode pli + warnings2 `shouldBe` [] + pli2 <- resolvePaths Nothing unresolvedPli2 + pli2 `shouldBe` (pli :: PackageLocationImmutable) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}